rearranging the rows and columns

[Pasi12]

HI..
I have this weird excel sheet and have 2 column header on top of each other and data below in 2 separate rows I need to clean this huge excel sheet with vba if possible. file and screen shot attached.

Thanks,
Pasi

[JKwan]

Give this a go

Sub TransposeData()
Dim LastRow As Long
Dim lRow As Long
Dim InputSheet As Worksheet
Dim OutputSheet As Worksheet
Dim OutputLastrow As Long

Set InputSheet = Worksheets("Sheet1")
Set OutputSheet = Worksheets("Sheet2")
LastRow = FindLastRow(InputSheet, "A")

OutputLastrow = 2
For lRow = 3 To LastRow Step 2
With OutputSheet
.Cells(OutputLastrow, "A") = InputSheet.Cells(lRow, "A")
.Cells(OutputLastrow, "B") = InputSheet.Cells(lRow, "B")
.Cells(OutputLastrow, "C") = InputSheet.Cells(lRow, "C")
.Cells(OutputLastrow, "D") = InputSheet.Cells(lRow, "D")
.Cells(OutputLastrow, "E") = InputSheet.Cells(lRow, "E")
.Cells(OutputLastrow, "F") = InputSheet.Cells(lRow, "F")
.Cells(OutputLastrow, "G") = InputSheet.Cells(lRow, "G")
.Cells(OutputLastrow, "H") = InputSheet.Cells(lRow, "H")
.Cells(OutputLastrow, "I") = InputSheet.Cells(lRow + 1, "A")
.Cells(OutputLastrow, "J") = InputSheet.Cells(lRow + 1, "B")
.Cells(OutputLastrow, "K") = InputSheet.Cells(lRow + 1, "C")
.Cells(OutputLastrow, "L") = InputSheet.Cells(lRow + 1, "D")
.Cells(OutputLastrow, "M") = InputSheet.Cells(lRow + 1, "E")
.Cells(OutputLastrow, "N") = InputSheet.Cells(lRow + 1, "F")
End With
OutputLastrow = OutputLastrow + 1
Next lRow
End Sub
Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
FindLastRow = WS.Range(ColumnLetter & Rows.Count).End(xlUp).Row
End Function

[Pasi12]

Jkwan, thanks so much you saved me a 2 day work! really appreciate it!
Pasi.

[Pasi12]

Jkwan,

How can I make the code not dependent on wksheet name? don't want to use sheet1,sheet2, make it like run the code from the current wksheet and add /copy it to next wksheet? like make it global.
Thanks a bunch!.

[JKwan]

here ya go, this will run the code from your active sheet to a new sheet

Sub TransposeData()
Dim LastRow As Long
Dim lRow As Long
Dim InputSheet As Worksheet
Dim OutputSheet As Worksheet
Dim OutputLastrow As Long

Set InputSheet = ThisWorkbook.ActiveSheet
Set OutputSheet = ThisWorkbook.Worksheets.Add
OutputSheet.Name = "transposed"
LastRow = FindLastRow(InputSheet, "A")

OutputLastrow = 2
OutputSheet.Range("A1:M1") = Array("Patient", "Chart #", _
"Address1", "Address2", "City", "ST", _
"ZipCode", "Home Phone", "Office Phone", _
"Provider", "Birthdate", "SSN", "Gender")
For lRow = 3 To LastRow Step 2
With OutputSheet
.Cells(OutputLastrow, "A") = InputSheet.Cells(lRow, "A")
.Cells(OutputLastrow, "B") = InputSheet.Cells(lRow, "C")
.Cells(OutputLastrow, "C") = InputSheet.Cells(lRow, "D")
.Cells(OutputLastrow, "D") = InputSheet.Cells(lRow, "E")
.Cells(OutputLastrow, "E") = InputSheet.Cells(lRow, "F")
.Cells(OutputLastrow, "F") = InputSheet.Cells(lRow, "G")
.Cells(OutputLastrow, "G") = InputSheet.Cells(lRow, "H")
.Cells(OutputLastrow, "H") = InputSheet.Cells(lRow + 1, "A")
.Cells(OutputLastrow, "I") = InputSheet.Cells(lRow, "B")
.Cells(OutputLastrow, "J") = InputSheet.Cells(lRow + 1, "C")
.Cells(OutputLastrow, "K") = InputSheet.Cells(lRow + 1, "D")
.Cells(OutputLastrow, "L") = InputSheet.Cells(lRow + 1, "E")
.Cells(OutputLastrow, "M") = InputSheet.Cells(lRow + 1, "F")
End With
OutputLastrow = OutputLastrow + 1
Next lRow
End Sub
Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
FindLastRow = WS.Range(ColumnLetter & Rows.Count).End(xlUp).Row
End Function

[Pasi12]

Thank you sir! its much better not specifying the sheets..