Arranging the row data into Columns using VBA in excel? - vba

Question

I am adapting off of the question: Re-Arranging the row data in columns
I have Excel data set up as follows;
Collection LatDD LonDD Date Location Method Specie1 Specie2 Specie3(+-110 species columns in total)
ABS1 11.35 -10.3 2003-02-01 A Bucket 0 1 3
ABS2 11.36 -10.4 2003-02-02 B Stick 2 0 6
I would Like This Data to appear like so:
Collection Specie Count LatDD LonDD Date Location Method
ABS1 Specie1 11.35 -10.3 2003-02-01 A Bucket
ABS1 Specie2 1 11.35 -10.3 2003-02-01 A Bucket
ABS1 Specie3 3 11.35 -10.3 2003-02-01 A Bucket
ABS2 Specie1 2 11.36 -10.4 2003-02-02 B Stick
ABS2 Specie2 -11.36 -10.4 2003-02-02 B Stick
ABS2 Specie3 6 -11.36 -10.4 2003-02-02 B Stick
I attempted to adapt Ripsters original VBA code answer but unfortunately i was unable to figure how i would need to change it. Could someone please advise me on how to adjust his code to produce the desired output?
Here is his orginal vba code:
Sub Example()
Dim Resources() As String
Dim rng As Range
Dim row As Long
Dim col As Long
Dim x As Long
ReDim Resources(1 To (ActiveSheet.UsedRange.Rows.Count - 1) * (ActiveSheet.UsedRange.Columns.Count - 1), 1 To 3)
'Change this to the source sheet
Sheets("Sheet1").Select
'Read data into an array
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 2 To ActiveSheet.UsedRange.Columns.Count
x = x + 1
Resources(x, 1) = Cells(row, 1).Value ' Get name
Resources(x, 2) = Cells(1, col).Value ' Get date
Resources(x, 3) = Cells(row, col).Value ' Get value
Next
Next
'Change this to the destination sheet
Sheets("Sheet2").Select
'Write data to sheet
Range(Cells(1, 1), Cells(UBound(Resources), UBound(Resources, 2))).Value = Resources
'Insert column headers
Rows(1).Insert
Range("A1:C1").Value = Array("Resource", "Date", "Value")
'Set strings to values
Set rng = Range(Cells(1, 3), Cells(ActiveSheet.UsedRange.Rows.Count, 3))
rng.Value = rng.Value
End Sub

Answer 1

Try this:
Sub Example()
Dim row As Long
Dim col As Long
Dim x As Long
h1 = "Sheet1"
h2 = "Sheet2"
Sheets(h1).Select
x = 2
'Headers Sheet2
Sheets(h2).Cells(1, 1).Value = Sheets(h1).Cells(1, 1)
Sheets(h2).Cells(1, 2).Value = "Specie"
Sheets(h2).Cells(1, 3).Value = "Count"
Sheets(h2).Cells(1, 4).Value = Sheets(h1).Cells(1, 2)
Sheets(h2).Cells(1, 5).Value = Sheets(h1).Cells(1, 3)
Sheets(h2).Cells(1, 6).Value = Sheets(h1).Cells(1, 4)
Sheets(h2).Cells(1, 7).Value = Sheets(h1).Cells(1, 5)
Sheets(h2).Cells(1, 8).Value = Sheets(h1).Cells(1, 6)
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 7 To ActiveSheet.UsedRange.Columns.Count
Sheets(h2).Cells(x, 1).Value = Sheets(h1).Cells(row, 1).Value
Sheets(h2).Cells(x, 2).Value = Sheets(h1).Cells(1, col).Value
Sheets(h2).Cells(x, 3).Value = Sheets(h1).Cells(row, col).Value
Sheets(h2).Cells(x, 4).Value = Sheets(h1).Cells(row, 2).Value
Sheets(h2).Cells(x, 5).Value = Sheets(h1).Cells(row, 3).Value
Sheets(h2).Cells(x, 6).Value = Sheets(h1).Cells(row, 4).Value
Sheets(h2).Cells(x, 7).Value = Sheets(h1).Cells(row, 5).Value
Sheets(h2).Cells(x, 8).Value = Sheets(h1).Cells(row, 6).Value
x = x + 1
Next
Next
End Sub
Sheet1:
Sheet2:
A short versión:
Sub Example()
Dim row As Long
Dim col As Long
Dim x As Long
Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
Set Sh2 = ThisWorkbook.Worksheets("Sheet2")
Sh1.Select
'Headers Sheet2
Sh2.Cells(1, 1).Value = Sh1.Cells(1, 1)
Sh2.Cells(1, 2).Value = "Specie"
Sh2.Cells(1, 3).Value = "Count"
For i = 4 To 8
Sh2.Cells(1, i).Value = Sh1.Cells(1, i - 2)
Next
x = 2 'Starting row of sheet2.
For row = 2 To ActiveSheet.UsedRange.Rows.Count
For col = 7 To ActiveSheet.UsedRange.Columns.Count
Sh2.Cells(x, 1).Value = Sh1.Cells(row, 1).Value
Sh2.Cells(x, 2).Value = Sh1.Cells(1, col).Value
Sh2.Cells(x, 3).Value = Sh1.Cells(row, col).Value
For i = 4 To 8
Sh2.Cells(x, i).Value = Sh1.Cells(row, i - 2).Value
Next
x = x + 1
Next
Next
Sh2.Select
End Sub

Answer 2

another idea....
Your source data is in "Sheet1", starting at "A1", no empty values neither in Column A, nor in Row 1.
If you run the code, you will get the re-sorted table in "Sheet2" ( I omitted headers, though - too lazy....)
Hope this helps
Sub sort_new()
Dim col_no As Long, row_no As Long
Dim i As Long, j As Long, k As Long
Dim arr_DB As Variant, arr_new As Variant
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
ws1.Activate
row_no = ws1.Range(Cells(Rows.Count, 1), Cells(Rows.Count, 1)).End(xlUp).Row
col_no = ws1.Range(Cells(1, Columns.Count), Cells(1, Columns.Count)).End(xlToLeft).Column
arr_DB = ws1.Range(Cells(1, 1), Cells(row_no, col_no))
ReDim arr_new(1 To (row_no - 1) * (col_no - 6), 1 To 8)
For i = 2 To row_no
For j = 7 To col_no
k = k + 1
arr_new(k, 1) = arr_DB(i, 1) 'Collection
arr_new(k, 4) = arr_DB(i, 2) 'LatDD
arr_new(k, 5) = arr_DB(i, 3) 'LonDD
arr_new(k, 6) = arr_DB(i, 4) 'Date
arr_new(k, 7) = arr_DB(i, 5) 'Location
arr_new(k, 8) = arr_DB(i, 6) 'Method
arr_new(k, 2) = arr_DB(1, j) 'Each Specie(j) Column
arr_new(k, 3) = arr_DB(i, j) 'Each Specie(j) Column
Next
Next
ws2.Activate
ws2.Range(Cells(2, 1), Cells((row_no - 1) * (col_no - 6) + 1, 8)) = arr_new
End Sub