将许多工作表中未锁定的单元格复制到另一个工作簿中具有相同名称的其他工作表

Question

目的是将多个工作表中除“Sheet1”之外的所有未锁定单元格从 Workbook1（原始文件）复制到 Workbook2（目标文件），其中包含与 Workbook1 同名的工作表。

Workbook1 是一个清单，Workbook2 是一个更新版本，添加了新的工作表或额外的未锁定单元格。工作簿和工作表名称与上面不同，但为简单起见已重命名。

我把一些代码放在一起：

Sub ImportData()

Dim vFile As Variant, wbCopyTo As Workbook, wsCopyTo As Worksheet, _
    wbCopyFrom As Workbook, wsCopyFrom As Worksheet, WorkRng As Range, _
    OutRng As Range, Rng As Range

Application.ScreenUpdating = False
Set wbCopyTo = ActiveWorkbook 'sets Workbook2 to destination file

'this allows user to select old file Workbook1
' - the workbook name may be different in practice
'    hence the ability to choose file
vFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
    "*.xls*", 1, "Select your old file", "Open", False)

If TypeName(vFile) = "Boolean" Then
    Exit Sub 'check file selected is okay to use else exits sub
Else
    Set wbCopyFrom = Workbooks.Open(vFile)
End If 'sets Workbook1 to origin file

For Each Worksheet In wbCopyFrom.Worksheets

    'should loop each worksheet, I think the error is part of this For statement
    If Worksheet.Name <> "Sheet1" Then

        On Error Resume Next

        Set wsCopyFrom = Worksheet 'sets Sheet2 to origin sheet

        'sets sheet matching name on previous line in Workbook2
        ' to destination sheet
        Set wsCopyTo = wbCopyTo.Worksheets(Worksheet.Name)

        wbCopyFrom.Activate
        wsCopyFrom.Select 'selects origin sheet
        Set WorkRng = wsCopyFrom.UsedRange
        For Each Rng In WorkRng
            If Rng.Locked = False Then
                If OutRng.Count = 0 Then
                    Set OutRng = Rng
                Else
                    Set OutRng = Union(OutRng, Rng)
                End If
            End If
        Next

        'a loop I found to pick all unlocked cells,
        ' seems to work fine for first sheet
        If OutRng.Count > 0 Then OutRng.Select

            Dim rCell As Range
            For Each rCell In Selection.Cells
                rCell.Copy Destination:=wsCopyTo.Cells(rCell.Row, rCell.Column)

           'a loop to copy all unlocked cells exactly as is
           ' in terms of cell reference on sheet,
           ' seems to work fine for first sheet
            Next rCell 

        End If





    'should go to Sheet3 next, seems to go to the sheet
    ' but then doesn't select any unlocked cells nor copy anything across
    Next Worksheet

    wbCopyFrom.Close SaveChanges:=False 'closes origin file Workbook1
    Application.ScreenUpdating = True

End Sub

它将选择所有未锁定的单元格并将其从 Workbook1 中的“Sheet2”复制到 Workbook2 中的“Sheet2”，但是，它不会循环遍历所有必要的工作表（“Sheet3”之后）。

Answer 1

• 您使用 On Error Resume Next 可能会掩盖问题
• 使用除 Worksheet 以外的其他名称作为 For Each 循环变量名称
• 您不会在每个工作表之后重置 OutRng

试试这样的：

Sub ImportData()

    Dim vFile As Variant, wbCopyTo As Workbook, wsCopyTo As Worksheet, _
        wbCopyFrom As Workbook, OutRng As Range, c As Range, wsCopyFrom As Worksheet

    Application.ScreenUpdating = False
    Set wbCopyTo = ActiveWorkbook 'sets Workbook2 to destination file

    vFile = Application.GetOpenFilename("All Excel Files (*.xls*)," & _
        "*.xls*", 1, "Select your old file", "Open", False)

    If TypeName(vFile) = "Boolean" Then Exit Sub

    Set wbCopyFrom = Workbooks.Open(vFile)

    For Each wsCopyFrom In wbCopyFrom.Worksheets
        If wsCopyFrom.Name <> "Sheet1" Then
            Set wsCopyTo = wbCopyTo.Worksheets(wsCopyFrom.Name)
            Set OutRng = UsedRangeUnlocked(wsCopyFrom)
            If Not OutRng Is Nothing Then
               For Each c In OutRng
                    c.Copy wsCopyTo.Range(c.Address)
               Next c
            End If
        End If
    Next wsCopyFrom

    wbCopyFrom.Close SaveChanges:=False 'closes origin file Workbook1
    Application.ScreenUpdating = True

End Sub

'return a range containing all unlocked cells within the UsedRange of a worksheet
Function UsedRangeUnlocked(sht As Worksheet) As Range
    Dim rngUL As Range, c As Range
    For Each c In sht.UsedRange.Cells
        If Not c.Locked Then
            If rngUL Is Nothing Then
                Set rngUL = c
            Else
                Set rngUL = Application.Union(rngUL, c)
            End If
        End If
    Next c
    Set UsedRangeUnlocked = rngUL
End Function