копирование определенных столбцов из одного Excel в другое Excel на основе имени заголовка столбца

Question

Я хочу скопировать столбцы из одного Excel в другое Excel на основе имени заголовка столбца. у меня есть два файла Excel с именами «Source» и «Destination», как показано ниже на изображении:

Source.xls

Destination.xls

Я хотел скопировать все столбцы из исходного файла и вставить их в целевой файл Excel на основе файла заголовка, т.е. в желтые заштрихованные столбцы. Потому что в конечном файле определена некоторая формула, как показано, и он вычисляет значения из столбца исходного файла.

Я пробовал базовые столбцы копирования и вставки. Хотя это работает, но требует много ручных вмешательств.

образец кода:

src.Range("A:A").Copy Destination:=trg.Range("A1")

src.Range("B:B").Copy Destination:=trg.Range("E1")

src.Range("C:C").Copy Destination:=trg.Range("I1")

Я ожидал бы что-то вроде поиска заголовка столбца из исходного файла и файла назначения, и если имена совпадают, то он вставит все столбцы в файл назначения. Поскольку я новичок в Excel, кто-нибудь может помочь решить эту проблему с помощью сценариев VBA

Answer 1

Пожалуйста, попробуйте это.

Option Explicit

Public Sub SpecificColCopy()
    Dim Wbs As Workbook
    Dim Wbd As Workbook
    Dim Wbm As Workbook
    Dim RealLastRow As Long
    Dim SourceCol As Long
    Dim Cell As Range
    Dim sourceWS As Worksheet, targetWS As Worksheet
    Dim MacroWS As Worksheet
    Dim SourceHeaderRow As Long: SourceHeaderRow = 1
    Dim SourceCell As Range
    Dim TargetHeader As Range
    Application.DisplayAlerts = False
    On Error Resume Next
    Set Wbm = ThisWorkbook
    Set MacroWS = Wbm.Worksheets("Sheet1")

    Set Wbs = Workbooks.Open("C:\mydirb\Source.xlsx") 'workbook needs to be closed state
    Set sourceWS = Wbs.Worksheets("Sheet1")

    Set Wbd = Workbooks.Open("C:\mydirb\Destination.xlsx") ''workbook needs to be closed state
    Set targetWS = Wbd.Worksheets("Sheet1")
    Set TargetHeader = targetWS.Range("A1:N1")
    On Error GoTo 0

    sourceWS.Activate
    For Each Cell In TargetHeader
        If Cell.Value <> "" Then
            Set SourceCell = Rows(SourceHeaderRow).Find _
                (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not SourceCell Is Nothing Then
                SourceCol = SourceCell.Column
                RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                If RealLastRow > SourceHeaderRow Then
                    Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                        SourceCol)).Copy
                    targetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
                End If
            End If
        End If
    Next


  MacroWS.Activate
  Wbs.Save
  Wbd.Save
  Wbs.Close
  Wbd.Close
  Application.DisplayAlerts = True
End Sub

 [![Souce_destination][1]][1]