Как скопировать целые столбцы с одного листа на другой, если он находит совпадение в заголовке на листе 2

Question

Я работаю с двумя листами. Один лист содержит полные необработанные данные, а другой - несколько заголовков из листа 1. Если он находит совпадение в заголовке, мне нужно скопировать полный столбец из листа один на лист 2

и копирует его на лист 2

Вот мой код, но я могу Не можете понять, как разбить l oop так, чтобы он проходил через каждый столбец на листе 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

Предполагая, что ваши заголовки находятся в строке 1 для обоих листов, и что вы всегда будете вставлять во второй ряд на Sheet2.

---

Только l oop через заголовки столбцов на втором лист. Используйте 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