将列从一个工作簿复制到另一个工作簿

Question

我想用另一个工作簿中的数据填充保存宏的工作簿。根据源文件的生成方式，我需要复制的数据可以位于源文件的不同列上。因此，我可能会遇到问题，因为我可能会在错误的列上获取所需的数据，或者甚至可能获取不需要的数据。因此，我认为最好查找列标题（无论报告如何生成，它们总是相同的字符串）。我可以使用Find方法搜索标题，但是如何复制每个标题下方的行？我要粘贴数据的范围始终与粘贴工作簿上的范围相同，并且始终是第一张工作表。

以下是我当前的代码：

Sub Import()

' Looks up for the Source Report file and imports its data into wkbk that holds the macro

On Error Resume Next

' Defines Source Report file variable
    Dim SourceFile As Variant

' Opens the SourceFile
    MsgBox ("Open the SourceFile")
    SourceFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*")
    If SourceFile <> False Then
        Workbooks.Open Filename:=SourceFile
    End If

    SourceFileDir = Dir(SourceFile)

' Looks up the last row on SourceFile to copy the entire data later
    With Workbooks(SourceFileDir).Worksheets(1)
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    End With

' MsgBox ("The last row of data in the Source File is " & LastRow)

' Sets echo off before copying
    Application.ScreenUpdating = False

' Copies SourceFile data into paste file, the one that holds the macro

' Serial Number
    Workbooks(SourceFileDir).Worksheets(1).Range("E7:E" & LastRow).Copy
    ThisWorkbook.Worksheets(1).Range("A38").PasteSpecial xlPasteValues

' Product ID
    Workbooks(SourceFileDir).Worksheets(1).Range("A7:A" & LastRow).Copy
    ThisWorkbook.Worksheets(1).Range("B38").PasteSpecial xlPasteValues

' Gets out of copy mode
    Application.CutCopyMode = False

' Sets echo back on
    Application.ScreenUpdating = True

End Sub

我需要的总列数为9，上面的代码仅显示了其中两个，即序列号和产品ID。

感谢您的帮助。

Answer 1

工作簿到工作簿

调整“常量”部分和“标题”数组中下方的值。

Option Explicit

Sub Import()

' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro

    Const LastRowColumnS As Long = 1
    Const FirstRowS = 7
    Const FirstRowP = 38

    Dim Headers As Variant
    Headers = Array("Serial Number", "Product ID", "ID", _
      "Name4", "Name5", "Name6", _
      "Name7", "Name8", "Name9")

    Dim rng As Range
    Dim SourceFile As Variant
    Dim wsS As Worksheet
    Dim wsP As Worksheet
    Dim LastRowS As Long
    Dim CurColS As Long
    Dim CurColP As Long
    Dim NumberOfRows As Long
    Dim Count As Long
    Dim i As Long

    ' Opens Source File.
    MsgBox ("Open the SourceFile")
    SourceFile = Application.GetOpenFilename( _
      FileFilter:="Excel Files,*.xl*;*.xm*")
    If SourceFile <> False Then
        Workbooks.Open Filename:=SourceFile
    Else
        MsgBox "You selected cancel."
        Exit Sub
    End If

    ' Define worksheets.
    Set wsS = ActiveWorkbook.Worksheets(1)
    Set wsP = ThisWorkbook.Worksheets(1)

    ' Define last cell with data in Last Row Column of Source Sheet.
    Set rng = wsS.Columns(LastRowColumnS).Find( _
        What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
    If rng Is Nothing Then
        MsgBox "No data in column."
        Exit Sub
    End If
    NumberOfRows = rng.Row - FirstRowS + 1

    For i = 0 To UBound(Headers)
        ' Define column of Current Header in Source Sheet.
        Set rng = wsS.Cells.Find(What:=Headers(i), _
          After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
          LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not rng Is Nothing Then
            CurColS = rng.Column
            ' Define column of Current Header in Paste Sheet.
            Set rng = wsP.Cells.Find(What:=Headers(i), _
              After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
              LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
            If Not rng Is Nothing Then
                CurColP = rng.Column
                ' Write data from Source Sheet to Paste Sheet.
                wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
                  = wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
                ' Count the transfer.
                Count = Count + 1
            End If
        End If
    Next i

    ' Maybe close Source Workbook.
    'wsS.Parent.Close False

    MsgBox "Transferred data from '" & Count & "' columns."


End Sub

编辑：

由于某些标题在每张纸上具有不同的值（名称），因此您应该使用两个数组（每张纸一个）并适当地调整值：

Option Explicit

Sub Import()

' Looks up for the Source Report file and imports its data into
' wkbk that holds the macro

    Const LastRowColumnS As Long = 1
    Const FirstRowS = 7
    Const FirstRowP = 38

    Dim HeadSource As Variant
    Dim HeadPaste As Variant
    HeadSource = Array("Serial Number", "Product ID", "ID", _
      "Name4", "Name5", "Name6", _
      "Name7", "Name8", "Name9")
    HeadPaste = Array("Serial Number", "Product ID", "ID", _
      "Name4", "Name5", "Name6", _
      "Name7", "Name8", "Name9")

    Dim rng As Range
    Dim SourceFile As Variant
    Dim wsS As Worksheet
    Dim wsP As Worksheet
    Dim LastRowS As Long
    Dim CurColS As Long
    Dim CurColP As Long
    Dim NumberOfRows As Long
    Dim Count As Long
    Dim i As Long

    ' Opens Source File.
    MsgBox ("Open the SourceFile")
    SourceFile = Application.GetOpenFilename( _
      FileFilter:="Excel Files,*.xl*;*.xm*")
    If SourceFile <> False Then
        Workbooks.Open Filename:=SourceFile
    Else
        MsgBox "You selected cancel."
        Exit Sub
    End If

    ' Define worksheets.
    Set wsS = ActiveWorkbook.Worksheets(1)
    Set wsP = ThisWorkbook.Worksheets(1)

    ' Define last cell with data in Last Row Column of Source Sheet.
    Set rng = wsS.Columns(LastRowColumnS).Find( _
        What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
    If rng Is Nothing Then
        MsgBox "No data in column."
        Exit Sub
    End If
    NumberOfRows = rng.Row - FirstRowS + 1

    For i = 0 To UBound(HeadSource)
        ' Define column of Current Header in Source Sheet.
        Set rng = wsS.Cells.Find(What:=HeadSource(i), _
          After:=wsS.Cells(wsS.Rows.Count, wsS.Columns.Count), _
          LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
        If Not rng Is Nothing Then
            CurColS = rng.Column
            ' Define column of Current Header in Paste Sheet.
            Set rng = wsP.Cells.Find(What:=HeadPaste(i), _
              After:=wsP.Cells(wsP.Rows.Count, wsP.Columns.Count), _
              LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows)
            If Not rng Is Nothing Then
                CurColP = rng.Column
                ' Write data from Source Sheet to Paste Sheet.
                wsP.Cells(FirstRowP, CurColP).Resize(NumberOfRows).Value _
                  = wsS.Cells(FirstRowS, CurColS).Resize(NumberOfRows).Value
                ' Count the transfer.
                Count = Count + 1
            End If
        End If
    Next i

    ' Maybe close Source Workbook.
    'wsS.Parent.Close False

    MsgBox "Transferred data from '" & Count & "' columns."


End Sub