Question

我想根据列标题名称将列从一个Excel复制到另一个Excel。我有两个名为“ Source”和“ Destination”的Excel文件，如下图所示：

我想从源文件复制所有列，然后根据头文件将其粘贴到目标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]

特定列根据列标题名称从一个Excel复制到另一个Excel

1 个答案: