Цикл по рабочим книгам и копирование динамического диапазона в основную рабочую книгу

Question

У меня есть несколько таблиц из Excel, которые будут обновляться каждый месяц или около того, и я пытаюсь скопировать и вставить эти диапазоны из «основной рабочей книги» на несколько листов.Это работает так, что у меня уже есть 20 с лишним рабочих книг с этими «таблицами» диапазонов, но мне приходится вручную открывать эти рабочие книги, затем копировать и вставлять новые значения из основной рабочей книги и закрывать ее.

Sub openwb()

Dim wkbk As Workbook
Dim NewFile As Variant
Dim ws As Worksheet
    Dim rngCopy As Range, aCell As Range, bcell As Range
    Dim strSearch As String
    Dim StrFile As Variant
    Dim wb2 As Excel.Workbook


    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    StrFile = Dir("C:\temp\*.xlsx*")
    Do While Len(StrFile) > 0
    Set wb = Workbooks.Open(StrFile)




'NewFile = Application.GetOpenFilename("microsoft excel files (*.xl*), *.xl*")
'
'If NewFile <> False Then
'Set wkbk = Workbooks.Open(NewFile)

'''**********************


    strSearch = "Descitption"

    Set ws = Worksheets("TestCases")

    With ws
        Set aCell = .Columns(4).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bcell = aCell

            If rngCopy Is Nothing Then
                Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
            Else
                Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
            End If

            Do
                Set aCell = .Columns(4).FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bcell.Address Then Exit Do

                    If rngCopy Is Nothing Then
                        Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
                    Else
                        Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
                    End If
                Else
                    Exit Do
                End If
            Loop
        Else
            MsgBox SearchString & " not Found"
        End If

        '~~> I am pasting to Output sheet. Change as applicable
            Set wb2 = Workbooks.Open("C:\temp\Bulk tool\test1.xlsm")
        If Not rngCopy Is Nothing Then rngCopy.Copy 'paste to another worksheet Sheets("Output").Rows(1)


    End With


'**************************

             ActiveWorkbook.Close SaveChanges:=False
             Application.DisplayAlerts = True
         Application.ScreenUpdating = True
     StrFile = Dir

Loop

End Sub

Диапазон является динамическим, он может изменяться от 2 строк до 20, но в качестве примера можно привести A1:K20 и он перейдет в тот же диапазон к другой рабочей книге.

сначалапозвольте мне поблагодарить всех, кто помогает мне в этом.вот что у меня есть (см. код), когда я запускаю его, я получаю ошибку 1004, не уверенную в том, что я изменила, но она работала нормально, и я пытаюсь скопировать ее на другой лист.

Answer 1

Копирование и вставка значений на листе использует Range.Copy и Range.PasteSpecial.

Пример кода следующий:

Sub CopyThis()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Sheets(1)
Set Sht2 = ThisWorkbook.Sheets(2)
Sht1.Range("A1:D4").Copy
Sht2.Range("A1:D4").PasteSpecial xlPasteAll
End Sub

В качестве альтернативы, вы также можете перебирать значения. Я обычно делаю это из предпочтений, потому что я часто делаю «If Then» в циклах

Sub CopyThis2()
Dim Sht1 As Worksheet, Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Sheets(1)
Set Sht2 = ThisWorkbook.Sheets(2)
Dim i As Long, j As Long
For i = 1 To 4
    For j = 1 To 4
        Sht2.Cells(i, j).Value = Sht1.Cells(i, j).Value
    Next j
Next i
End Sub

Answer 2

Возможно, вы можете сделать маленькие трюки с кодированием, чтобы сделать это быстрее.Как и в этом ответе ниже

Циклический просмотр файлов в папке

Вы также можете использовать Application.Screenupdating = False перед циклом и True после цикла, так что вашпроцесс будет намного быстрее.В цикле вы можете поместить код, предложенный Parker.R ....

Также нет другого способа скопировать данные из рабочих книг, не открывая их в VBA. Все вы можетеИграйте так, как файлы открываются и закрываются, чтобы процесс стал быстрее.

Кроме Screenupdating еще несколько свойств, которые вы можете установить В соответствии с этим Ссылка

---

Код для цикла Использование FSO

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False


Dim objFSO As Object
Dim objFolder, sfol As Object
Dim objFile As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.getFolder(f_add) ''''f_add is the Address of the folder 

'''' Loop For Files in That Folder
For Each objFile In objFolder.Files
 ''''Your Code
Next

'''' Loop for All the Subfolders in The Folder
For Each sfol In objFolder.subfolders
''' Your Code Here
Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True