excel - 使用数组在工作表之间复制列

Question

我想将事件工作表中的一些列复制到在运行时打开的工作簿中。附加的代码运行良好，除了我想阅读源表中的列标题而不是硬定义它们，因为它们可能并不总是相同的。我要传输的行从源文件的第 2 行开始，也应该粘贴到粘贴文件的第 2 行。谢谢!
这是代码:

Option Explicit

Sub CopyPvtToTemplate()
' Copies the columns in the Source file and pastes them into template
' The Source file is the Active Sheet

Const LastRowColumnS As Long = 2
Const FirstRowS = 2
Const FirstRowP = 2

Dim HeadSource As Variant
Dim HeadPaste As Variant
Dim LastRow As Long

HeadSource = Array("Header Column I", "Header Column E", "Header Column F",  "Header Column G", "Header Column H", "Header Column B", "Header Column J")

HeadPaste = Array("Header Column A", "Header Column B", "Header Column C",   "Header Column D", "Header Column E", "Header Column F", "Header Column H")

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

' Define Source Worksheet and Last Row in Source file
Set wsS = ActiveSheet

With ActiveSheet
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
End With

' Open Paste file
Set PasteFile = Workbooks.Open("C:\Users\ etc.xlsx")

' Define Source Worksheet
Set wsP = PasteFile.Worksheets(2)

' 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

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

End Sub

Answer 1

我认为您采用这种方法是在为潜在的错误做好准备 - 即，如果您没有在代码中键入列标题的确切文本/标题数量等。另外，使用 ActiveSheet可能充满危险。话虽如此，下面的代码应该会给你你想要的 - 只需将名称更改为实际的标题以及目标文件。让我知道你怎么去。
编辑
在 OP 澄清后编辑代码。

Option Explicit
Sub CopyPvtToTemplate()
On Error GoTo GetOut
Application.EnableEvents = False

Dim LastRow As Long
Dim wb As Workbook, wsS As Worksheet, wsP As Worksheet
Dim sArray, pArray, i As Integer, j As Integer
Dim Scol As Integer, Pcol As Integer

Set wsS = ActiveSheet
Set wb = Workbooks.Open(ThisWorkbook.Path & "\etc.xlsx")    '<~~ change to suit
Set wsP = wb.Sheets(2)

LastRow = wsS.Cells(Rows.Count, 2).End(xlUp).Row

sArray = Array(9, 5, 6, 7, 8, 2, 10)
pArray = Array(1, 2, 3, 4, 5, 6, 8)

For i = 0 To UBound(sArray)
    Scol = sArray(i)
        For j = 0 To UBound(pArray)
            Pcol = pArray(i)
            wsS.Range(wsS.Cells(2, Scol), wsS.Cells(LastRow, Scol)).Copy wsP.Cells(2, Pcol)
        Next j
Next i

MsgBox "Transferred data from " & i & " columns"

Continue:
    Application.EnableEvents = True
    Exit Sub
GetOut:
    MsgBox Err.Description
    Resume Continue

End Sub