title: VBA Sorting of Data
body: <p><a href="https://i.stack.imgur.com/IdCJ9.jpg" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/IdCJ9.jpg" alt="sheet1"></a>
  <a href="https://i.stack.imgur.com/jdQzV.jpg" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/jdQzV.jpg" alt="sheet2"></a></p>
  
  <p><strong>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.</strong> 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).</p>
  
  <p><strong>The spaces shown in the second image would not be present if the respective header is not present.</strong></p>
  
  <p><strong>Question:</strong> 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).</p>
  
  <p><strong>Examples/Thoughts:</strong>
  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.</p>
  
  <p>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. </p>
  
  <pre><code>Sub main()
      Dim hedaerCell As Range
      Dim labelsArray As Variant
  
      With ThisWorkbook.Worksheets("Sheet2") '&lt;--| reference "headers" worksheet
          For Each hedaerCell In .Range("A1:K1") '&lt;--| loop through all "headers"
              labelsArray = GetValues(hedaerCell.Value) '&lt;--| 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 '&lt;--| reference "data" worksheet
          ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '&lt;--| size an array to store as many "labels" as passed 'header' occurrences
          Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '&lt;--| 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 &lt;&gt; firstAddress
          End If
      End With
      GetValues = labelsArray
  End Function
  </code></pre>
  
  <hr>
  
  <p>Addition:
  <a href="https://i.stack.imgur.com/Hb1Zo.jpg" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/Hb1Zo.jpg" alt="enter image description here"></a></p>
  
  <p>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?</p>
  
  <p><a href="https://i.stack.imgur.com/rcIOE.jpg" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/rcIOE.jpg" alt="enter image description here"></a></p>
  
  <p>Very strange because the line with the red dot copies fine in both but those four lines seem to fail. </p>