VBA Transpose Data and Insert Rows

[SMITEE]

Hello, I want a macro that will look at columns F through K and:

1. If a cell in those columns contains a value, then insert a row after
2. Transpose the value to column E
3. (Optional) auto-fill columns A, B, C, and D with the preceeding value

Note that if a cell in columns F-K has a value, then the corresponding cell in the preceeding column always has a value.

Before:
[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]abc[/TD]
[TD]fall[/TD]
[TD]blue[/TD]
[TD]hand[/TD]
[TD]back[/TD]
[TD]hip[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD]def[/TD]
[TD]spring[/TD]
[TD]red[/TD]
[TD]thigh[/TD]
[TD]head[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD]ghi[/TD]
[TD]winter[/TD]
[TD]green[/TD]
[TD]arm[/TD]
[TD]neck[/TD]
[TD]shoulder[/TD]
[TD]wrist[/TD]
[TD]elbow[/TD]
[TD]knee[/TD]
[TD]ankle[/TD]
[/TR]
[TR]
[TD]400[/TD]
[TD]jkl[/TD]
[TD]summer[/TD]
[TD]yellow[/TD]
[TD]abdomen[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

After:
[TABLE="width: 500"]
<tbody>[TR]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]abc[/TD]
[TD]fall[/TD]
[TD]blue[/TD]
[TD]hand[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]abc[/TD]
[TD]fall[/TD]
[TD]blue[/TD]
[TD]back
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]100[/TD]
[TD]abc[/TD]
[TD]fall[/TD]
[TD]blue[/TD]
[TD]hip[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD]def[/TD]
[TD]spring[/TD]
[TD]red[/TD]
[TD]thigh[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]200[/TD]
[TD]def[/TD]
[TD]spring[/TD]
[TD]red[/TD]
[TD]head
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD]ghi[/TD]
[TD]winter[/TD]
[TD]green[/TD]
[TD]arm[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD]ghi[/TD]
[TD]winter[/TD]
[TD]green[/TD]
[TD]neck
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD]ghi[/TD]
[TD]winter[/TD]
[TD]green[/TD]
[TD]shoulder
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD]ghi[/TD]
[TD]winter[/TD]
[TD]green[/TD]
[TD]wrist
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD]ghi[/TD]
[TD]winter[/TD]
[TD]green[/TD]
[TD]elbow
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD]ghi[/TD]
[TD]winter[/TD]
[TD]green[/TD]
[TD]knee
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]300[/TD]
[TD]ghi[/TD]
[TD]winter[/TD]
[TD]green[/TD]
[TD]ankle
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]400[/TD]
[TD]jkl[/TD]
[TD]summer[/TD]
[TD]yellow[/TD]
[TD]abdomen[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 

[rpaulson]

try this on a copy of your file,

Sub do_it()

lr = Range("A" & Rows.Count).End(xlUp).Row
sr = lr + 2

For r = 1 To lr

a = Cells(r, "A")
b = Cells(r, "B")
c = Cells(r, "C")
d = Cells(r, "D")


For x = 5 To Cells(r, Columns.Count).End(xlToLeft).Column

Cells(sr, "A") = a
Cells(sr, "B") = b
Cells(sr, "C") = c
Cells(sr, "D") = d
Cells(sr, "E") = Cells(r, x)
sr = sr + 1

Next x
Next r
End Sub

hth,

Ross

 

[SMITEE]

Hi Ross, I'm afraid that didn't work. I ran the macro and there were no changes to my worksheet.

 

[SMITEE]

I tried fiddling with the following macro without success.

Sub TransposeSpecial()
Dim lMaxRows As Long 'max rows in the sheet
Dim lThisRow As Long 'row being processed
Dim iMaxCol As Integer 'max used column in the row being processed


lMaxRows = Cells(Rows.Count, "E").End(xlUp).Row

lThisRow = 1 'start from row 1

Do While lThisRow < lMaxRows

iMaxCol = Cells(lThisRow, Columns.Count).End(xlToLeft).Column

If (iMaxCol > 1) Then
Rows(lThisRow + 1 & ":" & lThisRow + iMaxCol - 1).Insert
Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Copy
Range("E" & lThisRow + 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range(Cells(lThisRow, 2), Cells(lThisRow, iMaxCol)).Clear
lThisRow = lThisRow + iMaxCol - 1
lMaxRows = Cells(Rows.Count, "E").End(xlUp).Row
End If

lThisRow = lThisRow + 1
Loop
End Sub
Sub Test()


End Sub

 

[rpaulson]

I tested my code on a different computer and it worked. can anyone else please test it. and let me know.

Thanks,
Ross