PDA

View Full Version : Code to move row data to columns



mituttle
11-01-2010, 02:22 PM
Wondering if I can get some help using code to move data from rows to columns. I've created code that works as long as the header and data are on one row. Where I run into problems is when the data for the header goes into the next row. The .csv file contains the same headers (Date:, Tag:, Comment:) but in rows. Data for the Comment: header is the only one that spans multiple row. Any help would be greatly appreciated.

Example:
Column A, Column B
Date: (Header), 10/14/10 (Data)
Name: (Header), Point1 (Data)
Commnet: (Header), Instrucions1 (Data)
Instrucions2 (Data), blank
Instructions3 (Data), blank
Date: (Header), 10/15/10 (Data)
Name: (Header), Point2 (Data)
Commnet: (Header), Instrucions1 (Data)
Instrucions2 (Data), blank
Instructions3 (Data), blank

What I would like it to look like is:
Column A, Column B, Column C
Date:, Tag:, Comment:
10/14/10, Point1, Instruction1 Instruction2 Instruction3
10/15/10, Point2, Instruction1 Instruction2 Instruction3

Code I'm currently using:
Sub RowDataToColumn()
Dim Headings(), Heads As Range

'Set Column Headers for 1st Query, data starts on Row 1
Headings = Array("Date:")

'Set Range to Place Headers
Sheets("sheet2").Range("A1:A1") = Application.Transpose(Application.Transpose(Headings))

'Search for Header Data
For Each Heads In Sheets("sheet2").Range("A1:A1")
With Sheets("sheet1").Range("A1:B" & [a65536].End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:=Heads
.Offset(0, 1).Resize(.Rows.Count, 1).Copy
Sheets("sheet2").Cells(Rows.Count, Heads.Column).End(xlUp).Offset(1).PasteSpecial xlValues
.AutoFilter
End With
Next

'Set Column Headers for 2nd Query, data starts on 2nd row
Headings = Array("Name:", "Comment:")

'Set Range to Place Headers
Sheets("sheet2").Range("B1:C1") = Application.Transpose(Application.Transpose(Headings))

'Search for Header Data
For Each Heads In Sheets("sheet2").Range("B1:C1")
With Sheets("sheet1").Range("A1:B" & [a65536].End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:=Heads
.Offset(1, 1).Resize(.Rows.Count - 1, 1).Copy
Sheets("sheet2").Cells(Rows.Count, Heads.Column).End(xlUp).Offset(1).PasteSpecial xlValues
.AutoFilter
End With
Next

End Sub

mdmackillop
11-01-2010, 03:05 PM
Welcome to VBAX
You can post a sample workbook using Manage Attachments in the Go Advanced reply section.
Code can be formatted using the green VBA button.

mituttle
11-01-2010, 09:36 PM
Thanks - I attached an example workbook containing the code. sheet1 contains an example of the .csv file that would be imported.

Thanks again.