VBA Sorting of Data

Question

The problem i run into is that sometimes entire headers and data values are missing in the dataset and therefore using the last row in the script the data

Answer 1

I'm leaving my previous answer up for posterity's sake, but now that you've clarified your question I have a better answer for you.

I'm going to assume the following: 1. every two rows is a pair of headers/data; 2. the sets of row pairs may be unequal in length because if a particular header is missing for a particular row pair, there is no blank because the headers/data are shifted left; 3. there will be no blanks in the header rows until the end of the row 4. there may be blanks in the data row 5. the output should be every header (even if it only appears in 1 row) and rows of the associated data, one per header/data pair in the original sheet.

For example:

A|B|C|D|F|G|H|I  <--- some headers (missing E)
1|2|3|4|6|7|8|9  <--- data row 1
A|C|D|E|G|H|I    <--- some headers (missing B and F)
1|3|4|5|7|8|9    <--- data row 2

is a valid input sheet and the resulting output sheet would be:

A|B|C|D|E|F|G|H|I  <--- all headers
1|2|3|4| |6|7|8|9  <--- data row 1
1| |3|4|5| |7|8|9  <--- data row 2

Use a Scripting.Dictionary of Scripting.Dictionarys to keep track of the possibly different length row pairs of headers/data. The Scripting.Dictionary of headers allows you to add new headers as they appear. The nested Scripting.Dictionarys allow you to keep track of only those rows which have a value for a particular header, but also preserve the row number for later.

As noted in the comments, the code iterates through this structure to display ALL headers and the data associated with each row. "((inputRow - 1) / 2)" calculates the output row number. You'll notice I like to iterate for loops over the count and then use offsets for indexing. I find it easier to reason about my code this way, and I find operations are easier, but you could potentially change it if you want.

Public Sub CopyDataDynamically()
    Dim inputSheet As Worksheet
    Dim outputSheet As Worksheet

    Dim headers As Scripting.Dictionary
    Set headers = New Scripting.Dictionary

    Dim header As String
    Dim data As String

    Dim inputRow As Long
    Dim inputColumn As Long

    Set inputSheet = Worksheets("Sheet1")
    Set outputSheet = Worksheets("Sheet2")

    inputRow = 1

    While Not inputSheet.Cells(inputRow, 1) = ""
        inputCol = 1
        While Not inputSheet.Cells(inputRow, inputCol) = ""

            header = inputSheet.Cells(inputRow, inputCol).Value
            data = inputSheet.Cells(inputRow + 1, inputCol).Value

            If Not headers.Exists(header) Then
                headers.Add header, New Scripting.Dictionary
            End If
            headers(header).Add ((inputRow - 1) / 2) + 1, data
            inputCol = inputCol + 1
        Wend
        inputRow = inputRow + 2
    Wend

    'Output the structure to the new sheet
    For c = 0 To headers.Count - 1
        outputSheet.Cells(1, c + 1).Value = headers.Keys(c)
        For r = 0 To ((inputRow - 1) / 2) - 1
            If headers(headers.Keys(c)).Exists(r + 1) Then
                outputSheet.Cells(r + 2, c + 1).Value = headers(headers.Keys(c))(r + 1)
            End If
        Next
    Next
End Sub

Answer 2

I suggest, rather than copying column by column, you instead copy row by row.

Public Sub CopyData()
    Dim inputRow As Long
    Dim outputRow As Long
    Dim inputSheet As Worksheet
    Dim outputSheet As Worksheet

    Set inputSheet = Worksheets("Sheet1")
    Set outputSheet = Worksheets("Sheet2")

    'First, copy the headers
    inputSheet.Rows(1).Copy outputSheet.Rows(1)

    'Next, copy the first row of data
    inputSheet.Rows(2).Copy outputSheet.Rows(2)

    'Loop through the rest of the sheet, copying the data row for each additional header row
    inputRow = 3
    outputRow = 3
    While inputSheet.Cells(inputRow, 1) <> ""
        inputRow = inputRow + 1 'increment to the data row
        inputSheet.Rows(inputRow).Copy outputSheet.Rows(outputRow)
        inputRow = inputRow + 1 'increment to the next potential header row
        outputRow = outputRow + 1 'increment to the next blank output row
    Wend
End Sub