Копирование разблокированных ячеек из множества листов на другие листы с тем же именем в другой книге - PullRequest
Новая
       16

Копирование разблокированных ячеек из множества листов на другие листы с тем же именем в другой книге

0 голосов
/ 05 ноября 2018

Цель состоит в том, чтобы скопировать все разблокированные ячейки на нескольких листах, кроме «Лист1», из 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

Он выберет и скопирует все разблокированные ячейки из «Лист2» ​​в Workbook1 в «Лист2» ​​в Workbook2, однако он не будет циклически проходить по всем необходимым листам («Sheet3» и далее).

1 Ответ

0 голосов
/ 05 ноября 2018
  • возможно ваше использование On Error Resume Next маскирует проблемы
  • используйте в качестве имени переменной цикла 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
...