Transpose Horizontal Table

[omegaboost]

Dear All,

I need help to make the VBA script for transpose the horizontal excel table (Sheet "database") into table in sheet "Cnrt Table". I try to do with copy and paste special but it takes time and not effective.

Thank you

Best Regards

Omegaboost

[offthelip]

try this:

Sub movedata()
Dim datar As Variant


With Worksheets("Cnrt Table")
headings = .Range("a5:o5")
End With
With Worksheets("database")
dbheads = .Range("a1:ge1")
lastrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To 15
For j = 1 To 187
If headings(1, i) = dbheads(1, j) Then
'copy to column i
Worksheets("database").Activate
Worksheets("database").Range(Cells(2, j), Cells(lastrow, j)).Copy Worksheets("Cnrt Table").Cells(6, i)
Exit For
End If
Next j
Next i


End Sub

[omegaboost]

Dear offthelip,

Thank you for your reply but i got error on this part "Worksheets("database").Range(Cells(2, j), Cells(lastrow, j)).Copy Worksheets("Cnrt Table").Cells(6, i)".
Is there any solution for this error?

Thank you
Omegaboost

[mdmackillop]

This line should be as follows to include a missing qualifier

lastrow = .Cells(Cells.Rows.Count, "A").End(xlUp).Row

Also I'd tweak it slightly as follows to omit the sheet activation

Sub movedata()
Dim datar As Variant
With Worksheets("Cnrt Table")
headings = .Range("a5:o5")
End With
With Worksheets("database")
dbheads = .Range("a1:ge1")
lastrow = .Cells(Cells.Rows.Count, "A").End(xlUp).Row
For i = 1 To 15
For j = 1 To 187
If headings(1, i) = dbheads(1, j) Then
'copy to column i
Range(.Cells(2, j), .Cells(lastrow, j)).Copy Worksheets("Cnrt Table").Cells(6, i)
Exit For
End If
Next j
Next i
End With
End Sub

[offthelip]

@omega
What I have found interesting is that I am running Excel 2007 and the "lastrow" variable was set correctly inspite of my typo in missing the dot !!
So I didn't get the error. I presume you are running a more recent version.

@mdmackillop A good modification to reduce what is in the loop to a minimum

[mdmackillop]

@Offthelip
The error arises if you run the code from the "other" worksheet, in which case LastRow has that sheet value.

[omegaboost]

Dear offthelip
Dear mdmackillop

Thank you for your help. I already try the VBA and it is work only if run in the same worksheet. What about if i want to run it from other worksheet?

Once again, thank you in advance

Regards

Omegaboost

[snb]

Sub M_snb()
sn = Sheet9.Cells(1).CurrentRegion

With CreateObject("scripting.dictionary")
For j = 2 To UBound(sn)
For jj = 8 To 27
If sn(j, jj) = "" Then Exit For
.Item(.Count) = Array(sn(j, 2), sn(j, 3), sn(j, 4), sn(j, 5), sn(j, 6), sn(j, 7), sn(j, jj), sn(j, 28), sn(j, 48), sn(j, 68), sn(j, 88), sn(j, 108))
Next
Next
Sheet1.Cells(20, 1).Resize(.Count, 12) = Application.Index(.items, 0, 0)
End With
End Sub

[mdmackillop]

The code in Post #4 runs from any sheet.