遍历工作簿并将动态范围复制到主工作簿

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

也许您可以通过一些技巧来使编码更快。就像下面的这个答案

Looping through files in a Folder

您还可以在循环前使用Application.Screenupdating = False，在循环后使用True，这样您的处理过程就会更快。在循环中，您可以放入 Parker.R ....

建议的代码。

此外，没有其他方法可以在不通过VBA打开工作簿的情况下复制工作簿中的数据，您可以通过打开和关闭文件的方式来完成所有工作，从而使过程变得更快。

除了Screenupdating以外，您还可以根据此Link设置其他属性

---

要使用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