Question

我有一个主文件和源文件。
主文件：多个工作表，列A到J
源文件：多个工作表，列A到E

我设法做到了
1）在提示窗口中选择源文件
2）通过匹配工作表中A列中的值，将源文件中的C，D，E列复制并粘贴到C，D，E列中

我现在正尝试在多个工作表中重复此粘贴操作。
对于主文件和源文件，工作表名称的范围从“ F.01，F.02到F.10”，“ T.01，T.02到T.10”，“ IS.01到IS.05”。

我是VBA的新手-通过检查所有论坛和论坛，我设法完成了下面的代码。

确实需要您的帮助，以帮助我根据上面所述的工作表范围对某些内容进行编码，使其复制粘贴变得重复。
将源“ F.01”发送到母版“ F.01”，然后继续

Sub CommandButton2_Click()


Dim fileDialog As fileDialog
Dim strPathFile As String
Dim strFileName As String
Dim strPath As String
Dim dialogTitle As String
Dim wbSource As Workbook
Dim rngToCopy As Range
Dim rngRow As Range
Dim rngDestin As Range
Dim lngRowsCopied As Long
Dim dic        As Object
Dim ky          As Variant
Dim c          As Variant
Dim cel        As Range
Dim x          As String
Dim tgt As Range
Dim FR As Long
Dim SSheetList As Variant
Dim MSheetList As Variant


dialogTitle = "Navigate to and select required file."
Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
With fileDialog
.InitialFileName = "C:\Users\User\Documents"
'.InitialFileName = ThisWorkbook.Path & "\" 'Alternative to previous line
.AllowMultiSelect = False
.Filters.Clear
.Title = dialogTitle



If .Show = False Then
    MsgBox "File not selected to import. Process Terminated"
    Exit Sub
End If
strPathFile = .SelectedItems(1)
End With

Set wbSource = Workbooks.Open(Filename:=strPathFile)

SSheetList = Array("F.01", "F.02")
MSheetList = Array("F.01", "F.02")

Set sh1 = ThisWorkbook.Sheets(MSheetList)
Set sh2 = wbSource.Sheets(SSheetList)

Application.ScreenUpdating = False

If sh1 Is sh2 Then

For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
FR = 0
On Error Resume Next
FR = Application.Match(c, sh1.Columns(1), 0)
On Error GoTo 0

If FR <> 0 Then sh1.Range("C" & FR).Value = c.Offset(, 2)
If FR <> 0 Then sh1.Range("D" & FR).Value = c.Offset(, 3)
If FR <> 0 Then sh1.Range("E" & FR).Value = c.Offset(, 4)
Next c

End If

wbSource.Close SaveChanges:=False

Set fileDialog = Nothing
Set rngRow = Nothing
Set rngToCopy = Nothing
Set wbSource = Nothing
Set rngDestin = Nothing

'MsgBox "The data is copied"



End Sub

Answer 1

我已经修改了您的代码，请尝试以下操作：

    Sub CommandButton2_Click()


    Dim fileDialog As fileDialog
    Dim strPathFile As String
    Dim strFileName As String
    Dim strPath As String
    Dim dialogTitle As String
    Dim wbSource As Workbook
    Dim wbMaster As Workbook
    Dim wsSource, wsMaster As Worksheet
    Dim rngToCopy As Range
    Dim rngRow As Range
    Dim rngDestin As Range
    Dim lngRowsCopied As Long
    Dim dic        As Object
    Dim ky          As Variant
    Dim c          As Variant
    Dim cel        As Range
    Dim x          As String
    Dim tgt As Range
    Dim FR

    Set wbMaster = ThisWorkbook.Name


    dialogTitle = "Navigate to and select required file."
    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    With fileDialog
    .InitialFileName = "C:\Users\User\Documents"
    '.InitialFileName = ThisWorkbook.Path & "\" 'Alternative to previous line
    .AllowMultiSelect = False
    .Filters.Clear
    .Title = dialogTitle



    If .Show = False Then
        MsgBox "File not selected to import. Process Terminated"
        Exit Sub
    End If
    strPathFile = .SelectedItems(1)
    End With

    ''''''''
    'this is what I've modified:


    Set wbSource = Workbooks.Open(Filename:=strPathFile)

    For Each wsSource In wbSource.Sheets

    For Each wsMaster In wbMaster.Sheets

        If wsSource.Name = wsMaster.Name Then

        t = 2
            Do Until t = wbSource.wsSource.Cells(Rows.Count, 1).End(xlUp).Row

            c = wbSource.wsSource.Cells(t, 1).Value
            Set FR = wbMaster.wsMaster.Columns(1).Find(What:=c)

                If Not FR Is Nothing Then
                    Do Until FR Is Nothing

                    wbMaster.wsMaster.Cells(FR.Row, 3).Value = wbSource.wsSource.Cells(t, 2).Value
                    'Or
                     'wbMaster.wsMaster.Cells(FR.Row, 3).Copy  
                     'wbSource.wsSource.Cells(t, 2).PasteSpecial Paste:=xlPasteValues
                    wbMaster.wsMaster.Cells(FR.Row, 4).Value = wbSource.wsSource.Cells(t, 3).Value
                    wbMaster.wsMaster.Cells(FR.Row, 5).Value = wbSource.wsSource.Cells(t, 4).Value

                    Loop
                End If

            t = t + 1

            Loop

        End If
    Next wsMaster
Next wsSource

    ''''''''

    wbSource.Close SaveChanges:=False

    Set fileDialog = Nothing
    Set rngRow = Nothing
    Set rngToCopy = Nothing
    Set wbSource = Nothing
    Set rngDestin = Nothing

    'MsgBox "The data is copied"

    End Sub

Answer 2

找到解决方案

    Sub CommandButton2_Click()

    Dim fileDialog As fileDialog
   Dim strPathFile As String
   Dim dialogTitle As String
   Dim wbSource As Workbook, Mwb As Workbook
   Dim Ws As Worksheet, Mws As Worksheet
   Dim Cl As Range
   Dim FR As Long

   Set Mwb = ThisWorkbook
   dialogTitle = "Navigate to and select required file."
   Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
   With fileDialog
      .InitialFileName ="C:\Users\User\Documents"
      .AllowMultiSelect = False
      .Filters.Clear
      .Title = dialogTitle
      If .Show = False Then
         MsgBox "File not selected to import. Process Terminated"
         Exit Sub
      End If
      strPathFile = .SelectedItems(1)
   End With
   Application.ScreenUpdating = False
   Set wbSource = Workbooks.Open(FileName:=strPathFile)

   For Each Ws In wbSource.Worksheets
      If ShtExists(Ws.name, Mwb) Then
         Set Mws = Mwb.Sheets(Ws.name)
         For Each Cl In Ws.Range("A2", Ws.Range("A" & Rows.Count).End(xlUp))
            FR = 0
            On Error Resume Next
            FR = Application.Match(Cl.Value, Ws.Columns(1), 0)
            On Error GoTo 0
            If FR <> 0 Then Mws.Range("C" & FR).Value = Cl.Offset(, 2)
            If FR <> 0 Then Mws.Range("D" & FR).Value = Cl.Offset(, 3)
            If FR <> 0 Then Mws.Range("E" & FR).Value = Cl.Offset(, 4)
         Next Cl
      End If
      Set Mws = Nothing
   Next Ws

   wbSource.Close SaveChanges:=False
End Sub
Public Function ShtExists(ShtName As String, Optional Wbk As Workbook) As Boolean
    If Wbk Is Nothing Then Set Wbk = ActiveWorkbook
    On Error Resume Next
    ShtExists = (LCase(Wbk.Sheets(ShtName).name) = LCase(ShtName))
    On Error GoTo 0
End Function

VBA：从多个工作表复制粘贴到多个工作簿

2 个答案: