根據條件將單元格范圍從主工作簿復制到多個文件

Question

我的目標是從主工作簿復制並粘貼主工作表中的一系列單元格，並將這些單元格填充到測試文件夾（相同模板）中跨多個工作簿（具有相同工作表）的固定范圍。

主工作簿有一個命名范圍，其中列出了所有需要更新的工作簿。 這個主工作簿還有一系列單元格，可以將我想要復制的數據提取到各個工作簿中。 使用查找功能提取數據。 我想遍歷此列表並將此列表中的名稱與 Test 文件夾中的工作簿進行匹配。 如果匹配，則將主文件中查找函數的結果值復制到適當的工作簿中。

>         Sub CopyPasteData()
>         
>         Dim DataDir As Object
>         Dim Nextfile As Workbook
>         Dim MasterWB As Workbook
>         Dim fileCell As String
>         Dim newValues As Long
>         
>         DataDir = "C:\My Documents\Test\"
>         ChDir (DataDir)
>         Nextfile = Dir("*.xlsm")
>         Set MasterWB = ActiveWorkbook                                       'master workbook to extract data from
>     
>      
>         While Nextfile <> ""                                                'iterate through all macro enabled files in the subfolder
>     
>             For Each fileCell In MasterWB.Names("nameList").RefersToRange   'loop through all cells in
> the named range
>                 If fileCell = Nextfile Then                                 'if cell from named range matches with workbook, then replace over
> range of cells below
>     
>                     newValues = MasterWB.Sheets("Master").Range("L4:U4").Value
>                     Workbooks.Open (Nextfile)
>                     Workbooks(Nextfile).Sheets("Report1").Unprotect Password:="qwedsa"
>     
>     
>                     Workbooks(Nextfile).Sheets("Report1").Range("H10:R10") = newValues
>                     Workbooks(Nextfile).Protect Password:="qwedsa"
>                     Workbooks(Nextfile).Save
>                     Workbooks(Nextfile).Close
>     
>                 End If
>     
>             Next fileCell
>     
>             Nextfile = Dir()
>     
>         Wend
>     
>     End Sub

我似乎無法遍歷命名范圍並在工作簿之間適當地復制和粘貼查找值。 我不確定如何讓我的循環工作。 我如何使這段代碼工作？

修訂版 1：

Sub CopyandPasteData()

DataDir = "C:\My Documents\Test\"
ChDir (DataDir)
Nextfile = Dir("*.xlsm")
Set MasterWB = ActiveWorkbook
MasterWB.Activate

While Nextfile <> ""

    Dim rngCell As Range
    Dim rngList As Range
    Set rngList = MasterWB.Sheets("Master").Range("B9:B111")

    Workbooks.Open (Nextfile)
    Workbooks(Nextfile).Sheets("Report1").Unprotect Password:="qwedsa"

    With MasterWB.Sheets("Master")

        For Each rngCell In rngList

            If rngCell = Nextfile Then
                rngCell.Value = MasterWB("B4").Value
                newvalue = MasterWB.Sheets("Master").Range("L4:U4").Value
                Workbooks(Nextfile).Sheets("Report1").Range("H10:R10") = newvalue

            End If

        Next rngCell

    End With

    Workbooks(Nextfile).Protect Password:="qwedsa"
    Workbooks(Nextfile).Save
    Workbooks(Nextfile).Close
    Nextfile = Dir()
Wend

結束子

Answer 1

無需打開每個文件然后檢查它是否在您的列表中，您可以遍歷列表並檢查是否有匹配的文件，然后才打開並更新它。

Sub CopyandPasteData()
    
    Const PW As String = "qwedsa" 'use constants for fixed values
    Dim fldr As String, wbMaster As Workbook, wsMaster As Worksheet
    Dim c As Range, wb As Workbook

    fldr = "C:\My Documents\Test\"
    
    Set wbMaster = ActiveWorkbook
    Set wsMaster = wbMaster.Worksheets("Master")
    
    For Each c In wsMaster.Range("B9:B111").Cells
        If Len(Dir(fldr & c.Value)) > 0 Then          'file exists?
            Set wb = Workbooks.Open(fldr & c.Value)
            With wb.Sheets("Report1")
                .Unprotect Password:=PW    'unprotect sheet and copy data
                .Range("H10:R10").Value = wsMaster.Range("L4:U4").Value
                .Protect Password:=PW
            End With
            wb.Close savechanges:=True
            ' ### fix the line below to reference the correct range ###
            c.Value = wbMaster.Worksheets("sheetName").Range("B4").Value
        End If
    Next c

End Sub