VBA：按單元格中的特定文本復制和粘貼

Question

一個善良的靈魂為我提出的另一個問題制作了這個代碼。 但我正在考慮復制 sheet1 中的單元格，其中包含特定文本，然后將其粘貼到 sheet2 中。

所以我在 sheet1 中有一個數據輸入，數據輸入中的每一列都有一些標題，我想按特定的 header 名稱排序，復制它們，然后粘貼 header 與我的關鍵字匹配的兩行列，在 sheet2 . 將數據粘貼到 sheet2 中，應該在前兩行可用，就像在我的代碼中一樣。 真的想像現在一樣保留大部分代碼，然后可能只更改我在特定范圍內復制兩行的子代碼。 將不勝感激幫助:)

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

這將 Ark2 上的 row1 中的文本與 Ark1 上的 row1 中的文本匹配，並相應地復制行 2:3。

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