Transpose VBA Excel
plexus2121
Moderator Last seen
February 14, 2019
- Feb 11, 2019 at 12:30 PM
- Posts
- 2
- Registration date
- Monday February 4, 2019
- Last seen
- February 6, 2019
- Posts
- 2448
- Registration date
- Sunday September 12, 2010
- Status
2 replies
Best answer
- Posts
- 2448
- Registration date
- Sunday September 12, 2010
- Status
Hi Plexus,
The following code will work for your sample data:
Then I read you had 16 channels ...
Can you adjust the code to make that happen?
Best regards,
Trowa
The following code will work for your sample data:
Sub RunMe()
Dim lRow, x As Integer
Sheets("Sheet1").Select
lRow = Range("A1").End(xlDown).Row
For Each cell In Range("A2:A" & lRow)
If cell.Offset(0, 3).Value = vbNullString Then
x = 1
ElseIf cell.Offset(0, 4).Value = vbNullString Then
x = 2
ElseIf cell.Offset(0, 5).Value = vbNullString Then
x = 3
Else
x = 4
End If
Range(cell, cell.Offset(0, 1)).Copy
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(x).PasteSpecial
Range(cell.Offset(0, 6), cell.Offset(0, 8)).Copy
Sheets("Sheet2").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Resize(x).PasteSpecial
cell.Offset(0, 2).Resize(1, x).Copy
Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
Next cell
Application.CutCopyMode = False
End Sub
Then I read you had 16 channels ...
Can you adjust the code to make that happen?
Best regards,
Trowa
Glad we were able to help! Love us? Write us a review! Rate CCM
4389 users have said thank you to us this month
- Posts
- 2
- Registration date
- Monday February 4, 2019
- Last seen
- February 6, 2019
-Thank you so much for your help. I have edited the code to work on 16 channels. I also added some paste special values. One thing that I am unable to solve is the code does not handle empty cells in channels when pasting into sheet 2. It pastes down incorrectly then gets out of sync. Here is what I have:
Sub RunMe() Dim lRow, x As Integer Sheets("Sheet1").Select lRow = Range("A1").End(xlDown).Row For Each cell In Range("A2:A" & lRow) If cell.Offset(0, 3).Value = vbNullString Then x = 1 ElseIf cell.Offset(0, 4).Value = vbNullString Then x = 2 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 3 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 4 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 5 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 6 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 7 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 8 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 9 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 10 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 11 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 12 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 13 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 14 ElseIf cell.Offset(0, 5).Value = vbNullString Then x = 15 Else x = 16 End If Range(cell, cell.Offset(0, 1)).Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(x).PasteSpecial xlPasteValues Range(cell.Offset(0, 18), cell.Offset(0, 21)).Copy Sheets("Sheet2").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Resize(x).PasteSpecial xlPasteValues cell.Offset(0, 2).Resize(1, x).Copy Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True Next cell Application.CutCopyMode = False End SubI was confused as to what this step is doing and was wondering if this is causing the problem?
cell.Offset(0, 2).Resize(1, x).Copy Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=TrueOnce again thanks for your help!
Plex.
You were almost there, you just overlooked something.
The part where x is determined, the offset value for the column should increase by 1. In the amended code it goes from 3, 4, 5, 5, 5 .... instead of 3, 4, 5, 6, 7 ....
Take the cell from Range("A2:A" & lRow), then 2 cells to the right (offest(0,2) and then resize that cells to the number of channels that have values in them.
Let me know if something is still unclear.
Best regards,
Trowa