如果在工作表2的标题中找到匹配项，如何将整个列从一个工作表复制到下一个工作表

Question

我正在处理两张纸。一张纸具有完整的原始数据，而另一张纸具有从第一张纸中选择的几个标题。如果它在标题上找到匹配项，我需要它将整列从第一张纸复制到第二张纸中。

并将其复制到工作表2

到目前为止，这是我的代码，但是我无法弄清楚如何中断循环，以便它遍历工作表1上的每一列，直到找到匹配项为止：

Private Sub CommandButton1_Click()

Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As Range, shtTwoHead As Range`enter code here`
Dim headerOne As Range, headerTwo As Range

Set ShtOne = Sheets("Sheet1")
Set ShtTwo = Sheets("Sheet2")
'row count
Dim b As Long
b = ShtOne.Cells(Rows.Count, 1).End(xlUp).Row
'column count in sheet 1
Dim a As Long
a = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
'column count in sheet 2
Dim c As Long
c = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column

Dim lastCol As Long
'get all of the headers in the first sheet, assuming in row 1
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))

'get all of the headers in second sheet, assuming in row 1
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))

'stops the visual flickering of files opening and closing - run at the background
Application.ScreenUpdating = False

'start loop from first row to last row
'For i = 1 To a
i = 1
j = 0
'actually loop through and find values
For Each headerOne In shtOneHead
j = j + 1
    For Each headerTwo In shtTwoHead
    'copy and paste each value
            If headerTwo.Value = headerOne.Value Then

    'copies one row at a time (a bit slow)
               ' headerOne.Offset(i, 0).Copy
               ' headerTwo.Offset(i, 0).PasteSpecial xlPasteAll

    'copies whole rows at a time
            ShtOne.Columns(i).Copy ShtTwo.Columns(j)
            i = i + 1
                Application.CutCopyMode = False
        Exit For
        End If
    Next headerTwo
Next headerOne

'Next

End Sub

Answer 1

假设页眉在两张纸的第一行上，并且您将始终粘贴在Sheet2的第二行上。

---

仅循环浏览第二张纸上的列标题。用Range.Find搜索Sheet1上的每个标题。如果找到标题，请复制并粘贴]

Sub Headerz()

Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")

Dim LC As Long, i As Long, LR As Long
Dim Found As Range

LC = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column


For i = 1 To LC
    Set Found = ws1.Rows(1).Find(ws2.Cells(1, i).Value)

    If Not Found Is Nothing Then

        LR = ws1.Cells(ws1.Rows.Count, Found.Column).End(xlUp).Row
        ws1.Range(ws1.Cells(2, Found.Column), ws1.Cells(LR, Found.Column)).Copy
        ws2.Cells(2, i).PasteSpecial xlPasteValues

    End If

    Set Found = Nothing
Next i

End Sub