VBA: copy and paste by specific text in a cell

Question

a kind soul made me this code for another question i asked. But im thinking about copying cells in sheet1, with specific text in it, and then pasting it in sheet2.

So i got a data input in sheet1, there is some headers for each column in the data input, and i want to sort by specific header names, copy them, and paste the two rows of the columns which header matches my keywords, in sheet2. Pasting the data in sheet2, should be at the first two lines available, like here in my code already. Really want to keep most of the code like it is now, and then maybe only change the sub where i copy the two rows in a specific range. Would appreciate the help:)

Option Explicit

Sub call_copy_sub_ranges()

    Dim ws1 As Worksheet, wsOut As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("Ark1")
    Set wsOut = ThisWorkbook.Worksheets("Ark2")

    Dim ar
    ar = Array("HeaderA", "HeaderB", "HeaderC", "HeaderD", "HeaderE", _
    "HeaderF", "HeaderG", "HeaderH", "HeaderI", "HeaderJ", "HeaderK", _
    "HeaderL", "HeaderM", "HeaderN", "HeaderO", "HeaderP", "HeaderQ", _
    "HeaderR", "HeaderS", "HeaderT", "HeaderU", "HeaderV", "HeaderW", _
    "HeaderX", "HeaderY", "HeaderZ", "HeaderAA", "HeaderAB", "HeaderAC", _
    "HeaderAD", "HeaderAE", "HeaderAF", "HeaderAG", "HeaderAH", "HeaderAI", _
    "HeaderAJ", "HeaderAK", "HeaderAL", "HeaderAM", "HeaderAN", "HeaderAO", _
    "HeaderAP", "HeaderAQ", "HeaderAR", "HeaderAS", "HeaderAT", "HeaderAU", _
    "HeaderAV", "HeaderAW", "HeaderAX", "HeaderAY")
   
    wsOut.Range("A1:AY1").Value = ar
    copy_sub_ranges ws1, wsOut
    MsgBox "Done"

End Sub


Sub copy_sub_ranges(ByVal ws1 As Worksheet, ByVal wsOut As Worksheet)

    Dim rng As Range, rngOut As Range, ar, s
    ar = Array("S2:S3", "BF7:BH8", "BI9:CC10", _
    "CD9:CQ9", "CR9:CS10", "CT9:CV9", "CW9:CW10", "CX10", "EE9:EI10")
               
    ' target
    Set rngOut = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp)
    If Not IsEmpty(wsOut.Range("A1").Text) Then
        Set rngOut = rngOut.offset(1, 0)
    End If

    For Each s In ar
        Set rng = ws1.Range(s)
        Debug.Print rng.Address, rngOut.Address
   
        rng.Copy rngOut
        Set rngOut = rngOut.offset(0, rng.Columns.Count)
    Next

    ' underline
    Set rng = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp)
    With rng.Resize(1, rngOut.Column - 1).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .Weight = xlMedium
    End With

End Sub

Answer 1

This matched the text in row1 on Ark2 with the text in row1 on Ark1 and copies rows 2:3 accordingly.

Option Explicit

Sub call_copy_cols()

    Dim ws1 As Worksheet, wsOut As Worksheet
    Dim dict As Object, k As Variant
    Set dict = CreateObject("Scripting.Dictionary")

    Dim rngSearch As Range, rngFound As Range, rngOut As Range
    Dim iLastCol As Long, i As Long, s As String, iLastRow As Long
    Dim colSource As Long, colTarget As Long

    Set ws1 = ThisWorkbook.Worksheets("Ark1")
    Set wsOut = ThisWorkbook.Worksheets("Ark2")

    ' Get List of header text on Output Sheet to search for
    'iLastCol = wsOut.Cells(1, Columns.Count).End(xlToLeft).Column
    'For i = 1 To iLastCol
    '    s = Trim(wsOut.Cells(1, i))
    '    If Len(s) > 0 Then
    '        dict.Add s, i
    '        'Debug.Print s, i
    '    End If
    'Next

    ' specify headers
    dict.Add "Header1", 1
    dict.Add "Header2", 2
    dict.Add "Header3", 3
    For Each k In dict.keys
        wsOut.Cells(1, dict(k)) = k
    Next

    ' ws1 header range
    iLastCol = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
    Set rngSearch = ws1.Range("A1").Resize(1, iLastCol)
    'Debug.Print rngSearch.Address

    ' output range
    iLastRow = wsOut.UsedRange.Rows.Count
    Set rngOut = wsOut.Cells(iLastRow + 1, 1)

    ' copy each column
    For Each k In dict.keys
       Set rngFound = rngSearch.Find(k)
       If rngFound Is Nothing Then
           MsgBox "'" & k & "' Not found in headers", vbCritical
           Exit Sub
       Else
          'copy to output
          colSource = rngFound.Column
          colTarget = dict(k)
          ws1.Range("A2:A3").Offset(0, colSource - 1).Copy rngOut.Offset(0, colTarget - 1)
          'Debug.Print k, colSource, colTarget
       End If
    Next

End Sub