Copying unlocked cells from many sheets to other sheets with the same name in another workbook

Question

The intent is to copy all unlocked cells in multiple sheets except "Sheet1" from Workbook1 (origin file) to Workbook2 (destination file) which contains worksheets with the same names as Workbook1.

Workbook1 is a checklist and Workbook2 is an updated version with additions of new worksheets or extra unlocked cells. The workbook and worksheet names are different from above but have renamed everything for simplicity.

I put some code together:

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

It will select and copy all unlocked cells from "Sheet2" in Workbook1 to "Sheet2" in Workbook2, however, it will not cycle through all of the sheets necessary ("Sheet3" onwards).

Tim Williams Tim Williams · Accepted Answer · 2018-11-04T21:45:03

it's possible your use of On Error Resume Next is masking problems
use something other than Worksheet as your For Each loop variable name
you don't reset OutRng after each worksheet

Try something like this:

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

Copying unlocked cells from many sheets to other sheets with the same name in another workbook

1 Answers