Excel VBA - 從列表中的工作表復制粘貼

Question

我的情況有點簡單，但我缺乏 VBA 知識來自動化這個過程。

在名為“宏”的 Excel 文件中，我有兩個不同工作簿中的工作表的關系（A 列和 B 列），我想從中復制/粘貼值。 我希望能夠運行一個宏來選擇並打開兩個工作簿，循環工作簿 1 的工作表列表，復制所選范圍（所有工作表都相同）並將其粘貼到工作簿 2 的對應工作表中。

例如：

我需要打開工作簿 1 和 2（由用戶選擇），並將值從工作表 ABC 復制到工作表 XYZ，將 DEF 復制到 UVW...等等

工作簿 1	工作簿 2
表 ABC	片材 XYZ
表 DEF	表 UVW

希望這很清楚。 任何幫助表示贊賞！

Answer 1

將表格放在 sheet1 上，單元格 A1 的左上角。 將常量 RNG_TO_COPY 配置為您的范圍。

Option Explicit
sub copyrange()

    Dim RNG_TO_COPY As String

    Dim ws As Worksheet, wb(2) As Workbook
    Dim dict(2), filename(2) As String, s(2) As String
    Dim iLastRow As Long, r As Long
    Dim n As Integer, msg As String

    ' open workbooks and compile list of worksheet names
    For n = 1 To 2
        s(n) = GetFile(n)
        If Len(s(n)) > 0 Then
            Set dict(n) = CreateObject("Scripting.Dictionary")
            Set wb(n) = Workbooks.Open(s(n))
            For Each ws In wb(n).Sheets
                dict(n).Add ws.Name, ws.Index
            Next
        Else
           Exit Sub
        End If
    Next
      
    ' check data valid
    Set ws = ThisWorkbook.Sheets(1)
    iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    For r = 2 To iLastRow
        For n = 1 To 2
            s(n) = ws.Cells(r, n)
            If Not dict(n).exists(s(n)) Then
                msg = msg & vbCrLf & "'" & s(n) & "' in " & wb(n).Name
            End If
        Next
    Next

    ' errors
    If msg <> "" Then
        MsgBox "Sheets do not exist" & msg, vbCritical
        GoTo finish
    End If

    ' copy ranges
    For r = 2 To iLastRow
        s(1) = ws.Cells(r, 1)
        s(2) = ws.Cells(r, 2)
        RNG_TO_COPY = ws.Cells(r, 3)
        wb(1).Sheets(s(1)).Range(RNG_TO_COPY).Copy wb(2).Sheets(s(2)).Range(RNG_TO_COPY)
    Next

    MsgBox "Finished copying from " & wb(1).Name & " to " & wb(2).Name, vbInformation

finish:
    wb(1).Close False
    wb(2).Close True

End Sub
Function GetFile(n As Integer) As String
    Dim f
    Set f = Application.FileDialog(msoFileDialogFilePicker)
    With f
        .Title = "Select File " & n
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then Exit Function
        GetFile = .SelectedItems(1)
    End With
End Function