Need Major Help on the Macro

[bioyyy]

Hello:

I need your help desperately. Transpose the columns into rows with a
condition. For example,

Q R S T U V
X Y Z AA AB
Row 26 6 A1 B1 C1 D1 1:1 1:2
12:2
Row 27 5 B2 C1 -- -- --- --

So, here are the steps what I would like to you help me,

(1) if row 26, col Q has 6, copy 6 columns from V to AB (ie. # column copy =
number enter in row 26 col Q.
(2) Tranpose and put in col AZ, row 26 (starting on row 26)
(3) Skip 2 rows,
(4) then repeat for row 27. So, if row 27, col Q has 5, copy 5 columns from
V to AA. Tranpose, skip 2 rows and repeat that up to row 1000.

Your help is greatly appreciated.

 

[Per Jessen]

Hi

Try to see if this is what you need:

Sub Help()
TargetCol = "Q"
DestRow = 26
DestCol = "AZ"

For TargetRow = 26 To 1000
CopyCols = Cells(TargetRow, TargetCol).Value
Range("V" & TargetRow).Resize(1, CopyCols).Copy
Sheets("Sheet1").Cells(DestRow, DestCol).PasteSpecial
Paste:=xlAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
DestRow = DestRow + CopyCols + 2
Next
Application.CutCopyMode = False
End Sub

Regards,
Per

 

[Sheeloo]

If you skip two rows from row 26 you would be on 29 (or 28 if you count 26
too) but not on 27...

Also if you are using Excel 2003 then you can have a maximum of 256
coulmns....

Pl. respond on how you want to handle...

Give row nos of first few you want to handle...

 

[Barb Reinhardt]

Try this. I had to make some assumptions so come back if it doesn't work.

Option Explicit
Sub Transpose()
Dim aWS As Worksheet
Dim myRow As Long
Dim myDelta
Dim myRange As Range
Dim bRow As Long
Dim i As Long

bRow = 26

Set aWS = ActiveSheet
For myRow = 26 To 1000
myDelta = aWS.Cells(myRow, "Q").Value2
If IsNumeric(myDelta) And myDelta > 0 Then
Set myRange = aWS.Cells(myRow, "V").Resize(1, myDelta)
Debug.Print myRange.Address
'Need to tranpose this
For i = bRow To bRow + myRange.Count
aWS.Cells(i, "AZ").Value = myRange.Cells(i - bRow + 1).Value
Next i
bRow = bRow + 2
End If

Next myRow

End Sub

 

[bioyyy]

Sheeloo:

Thanks for your help. It does not matter. I'd like to copy something from
col V to AB (depend on value of Q, row 26----row 1000) and tranpose, paste at
row 26 col AZ, insert 2 Cells? maybe and continue to read from the table line
or row 27. Thanks.

 

[bioyyy]

Per Jessen:

Thanks for the code. However, there is red in line

Paste:=xlAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True


Would you please correct.

THanks again.

 

[bioyyy]

Barb.

Thanks. I did try, but it does not insert 2 rows after line 26. In another
words, tranpose consecutively. Also, it seems like it does not read values
from col Q.

Thanks,

 

[bioyyy]

Per Jessen:
I just fixed a litle bit. Here how I did :

Sub Help()
TargetCol = "Q"
DestRow = 26
DestCol = "AZ"

For TargetRow = 26 To 1000
CopyCols = Cells(TargetRow, TargetCol).Value
Range("V" & TargetRow).Resize(1, CopyCols).Copy
Sheets("Sheet6").Cells(DestRow, DestCol).PasteSpecial Paste:=xlAll,
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
DestRow = DestRow + CopyCols + 2
Next
Application.CutCopyMode = False
End Sub

BUT there is a bug at line: Range("V" & TargetRow).Resize(1, CopyCols).Copy.
It 's in yellow. You can tell I don't know much about the code. Thanks again.

 

[Sheeloo]

Try this
(Line nos are just so that you have to have the entire line either in one
row or if they break then have an _ at the end of the first row

I have used the code posted by Jessen and just added a check for value in Q
being greater than 0 for the current cell.
'---------------------------
Sub Help()
TargetCol = "Q"
DestRow = 26
DestCol = "AZ"
For TargetRow = 26 To 50
CopyCols = Cells(TargetRow, TargetCol).Value
'Added IF condition to check for blanks or zeroes
'in Col Q
If CopyCols > 0 Then
Range("V" & TargetRow).Resize(1, CopyCols).Copy
Sheets("Sheet1").Cells(DestRow, DestCol).PasteSpecial _
Paste:=xlAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
DestRow = DestRow + CopyCols + 2
End If
Next
Application.CutCopyMode = False
End Sub

 

[Sheeloo]

Row nos may not show up... on my previous post
Just add the IF and END IF statements to the original code...

 

[Per Jessen]

Hi....

Thanks for your reply, try this:

Sub Help()
TargetCol = "Q"
DestRow = 26
DestCol = "AZ"

For TargetRow = 26 To 1000
CopyCols = Cells(TargetRow, TargetCol).Value
If CopyCols > 0 Then
Range("V" & TargetRow).Resize(1, CopyCols).Copy
Sheets("Sheet1").Cells(DestRow, DestCol).PasteSpecial _
Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, _
Transpose:=True
DestRow = DestRow + CopyCols + 2
End If
Next
Application.CutCopyMode = False
End Sub

BTW: You should always state the error description which you recive as
it's much eaysier to look for a error when you know what to look for.

Regards,
Per

 

[bioyyy]

Per Jessen:

Work very nice. Thanks for all your help. You are my HERO. also, thanks to
Sheeloo. Your guys are great!

 

[Per Jessen]

Thanks for your reply. I'm glad to help

Regards,
Per