VBA Sorting of Data - vba

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 is shifted up by one. For example, if i removed H11:H12 completely on sheet1 then the values for the H column associated with the data set in A11:K11 will actually be from the data set A13:K13 (or cell value H14).
The spaces shown in the second image would not be present if the respective header is not present.
Question: Given the following code; Do you think it is possible to match the data to headers and use the original offset row number alongside the column that it is matched to on sheet 2 and paste the values there? Instead the current code (and only method that worked was to find the last row).
Examples/Thoughts:
I'm thinking that the script will have to take a cell (such as D9 and recognizes it is a D and offsets to select D10 and matches that D9 record to sheet 2 column D and pastes the D10 data in D10 rather than D5.
second example, Script takes I17 and recognizes it matches I to sheet 2 column I and then offsets to select/copy and pastes the I19 data in I18 rather than I9.
Sub main()
Dim hedaerCell As Range
Dim labelsArray As Variant
With ThisWorkbook.Worksheets("Sheet2") '<--| reference "headers" worksheet
For Each hedaerCell In .Range("A1:K1") '<--| loop through all "headers"
labelsArray = GetValues(hedaerCell.Value) '<--| fill array with all labels found under current "header"
.Cells(.Rows.Count, hedaerCell.Column).End(xlUp).Offset(1).Resize(UBound(labelsArray)).Value = Application.Transpose(labelsArray)
Next
End With
End Sub
Function GetValues(header As String) As Variant
Dim f As Range
Dim firstAddress As String
Dim iFound As Long
With ThisWorkbook.Worksheets("Sheet1").UsedRange '<--| reference "data" worksheet
ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '<--| size an array to store as many "labels" as passed 'header' occurrences
Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '<--| start seraching for passed 'header'
If Not f Is Nothing Then
firstAddress = f.Address
Do
iFound = iFound + 1
labelsArray(iFound) = f.Offset(1)
Set f = .FindNext(f)
Loop While f.Address <> firstAddress
End If
End With
GetValues = labelsArray
End Function
Addition:
Seems like there is an exception that prevents these cell values from being copied over, if i do it manually the below screenshot would be correct. Any tips to diagnose?
Very strange because the line with the red dot copies fine in both but those four lines seem to fail.

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