Question

我刚刚开始使用vba。

用Google搜索了很长时间才找到答案。我编写了将单元格复制到新工作表的代码。我必须为文件夹中的每个文件执行此操作。

所以我尝试使用循环。但是在过程中间发生错误（下标超出范围）

这是我的代码，适用于一个文件。

Sub add()

    Sheets.add.Name = "Good"
    GetBook = ActiveWorkbook.Name
    Sheets("Good").Range("A1") = GetBook
    Sheets("Report Details").Range("E6:E8").Copy
    With Sheets("Good").Range("B1")
        .PasteSpecial Paste:=xlPasteValues, Transpose:=True
    End With

    Sheet2.Activate
    Range(Range("A1").End(xlDown), Range("H1").End(xlDown)).Copy
    With Sheets("Good").Range("E1")
        .PasteSpecial Paste:=xlPasteValues
        .PasteSpecial Paste:=xlPasteFormats
    End With

End Sub

这里我尝试循环但它不起作用，循环时第一个代码中出现问题

With Sheets("Good").Range("E1")

循环代码

    FolderPath = "C:\Users\Maxim Osipov\Documents\Mckinsey\BorisT\Project 3(Smart city solutions)\VBA collecting" 'change to suit
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath + "\"
    Filename = Dir(FolderPath & "*.xlsx")
    Do While Filename <> ""
        Application.ScreenUpdating = False
        Set wb = Workbooks.Open(FolderPath & Filename)
        'Call a subroutine here to operate on the just-opened workbook
        Call add
        Filename = Dir
    Loop
    Application.ScreenUpdating = True

End Sub

Answer 1

尝试这种轻微变化：

Sub add()

    'Sheets.add.Name = "Good"
    Sheets("Good").Range("A1") = ActiveWorkbook.Name
    Sheets("Report Details").Range("E6:E8").Copy
    Sheets("Good").Range("B1").PasteSpecial Paste:=xlPasteValues, Transpose:=True

    Sheets("Sheet2").Range(Range("A1").End(xlDown).Address, Range("H1").End(xlDown).Address).Copy
    Sheets("Good").Range("E1").PasteSpecial Paste:=xlPasteValues
    Sheets("Good").Range("E1").PasteSpecial Paste:=xlPasteFormats

End Sub

另见：

Microsoft：Range Object (Excel)
10 ways to reference Excel workbooks and sheets using VBA
MSDN：Refer to Sheets by Name
MSDN：How to Reference Cells and Ranges
MSDN：Range.Copy Method

Answer 2

我在弄清楚你的一些工作簿是什么时遇到了一些问题 - 正在打开的工作簿，或者正在粘贴的工作簿。

此代码将遍历文件夹中的xlsx文件，并将范围复制到包含VBA代码的工作簿。
我添加了一个函数来检查Good工作表是否已经存在，如果存在则使用它。

Public Sub Main()

    Dim FolderPath As String
    Dim FileName As String
    Dim WB As Workbook
    Dim WS As Worksheet

    FolderPath = "C:\Users\Maxim Osipov\Documents\Mckinsey\BorisT\Project 3(Smart city solutions)\VBA collecting\"
    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        Set WB = Workbooks.Open(FolderPath & FileName, False, True) 'Not updating links & is read-only.
        'You can't create two sheets with the same name,
        'so check if it exists first.
        If WorkSheetExists("Good") Then
            Set WS = ThisWorkbook.Worksheets("Good")
        Else
            'Add a worksheet to the workbook holding this code.
            Set WS = ThisWorkbook.Worksheets.Add
            WS.Name = "Good"
        End If
        'Pass the workbook and worksheet references to the procedure.
        Add WB, WS
        WB.Close SaveChanges:=False
        FileName = Dir
    Loop

End Sub

Public Sub Add(WrkBk As Workbook, wrkSht As Worksheet)

    Dim LastCell As Range
    Dim LastRow As Long

    With wrkSht

        'Find the last cell.
        'You could use "LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row"
        'but not sure how much data is in the Sheet2.
        Set LastCell = .Cells.Find("*", _
                              After:=.Range("A1"), _
                              LookAt:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByColumns, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False)
        If LastCell Is Nothing Then
            LastRow = 1
        Else
            LastRow = LastCell.Row + 1
        End If

        .Cells(LastRow, 1) = WrkBk.Name

        WrkBk.Worksheets("Report Details").Range("E6:E8").Copy
        .Cells(LastRow, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True

        With WrkBk.Worksheets(2)
            .Range(.Cells(1, 1), .Cells(.Rows.Count, "H").End(xlUp)).Copy
        End With
        With .Cells(LastRow, "E")
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
        End With

    End With

End Sub

Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
    Dim wrkSht As Worksheet

    If WrkBk Is Nothing Then
        Set WrkBk = ThisWorkbook
    End If

    On Error Resume Next
        Set wrkSht = WrkBk.Worksheets(SheetName)
        WorkSheetExists = (Err.Number = 0)
        Set wrkSht = Nothing
    On Error GoTo 0
End Function

如果您只能在正在打开的工作簿中使用Sheet2引用，则此功能将找到它：

Public Function GetWorkSheet(sCodeName As String, Optional wrkBook As Workbook) As Worksheet

    Dim wrkSht As Worksheet

    If wrkBook Is Nothing Then
        Set wrkBook = ThisWorkbook
    End If

    For Each wrkSht In wrkBook.Worksheets
        If wrkSht.CodeName = sCodeName Then
            Set GetWorkSheet = wrkSht
            Exit For
        End If
    Next wrkSht

End Function

要使用它，只需更改Add程序底部的这一行：

With WrkBk.Worksheets(2)

到

With GetWorkSheet("Sheet2", WrkBk)

Answer 3

最佳做法（并且热烈推荐）不要使用Activate / ActiveXXX / Select / Selection模式并充分利用完全合格的范围参考工作簿

所以你可以按照以下方式重构你的add()子句（评论中的解释）：

Option Explicit

Sub add(ws As Worksheet)
    Dim repDetRngToCopy As Range, sht2RngToCopy As Range

    With ws 'reference passed worksheet
        Set repDetRngToCopy = .Parent.Worksheets("Report Details").Range("E6:E8") 'set needed range in "Report Details" worksheet of the same workbook the currently referenced sheet (i.e. the passed one) belongs to
        With .Parent.Worksheets(2) 'reference Sheet2 worksheet of the same workbook the currently referenced sheet belongs to
            Set sht2RngToCopy = .Range(Range("A1").End(xlDown), .Range("H1").End(xlDown)) 'set needed range in currently referenced sheet (i.e. Sheet2)
        End With

        'now start filling cells of referenced sheet (i.e. the passed one)
        .Range("A1") = .Name

        repDetRngToCopy.Copy 'copy from the range previously defined in "Report Details"
        .Range("B1").PasteSpecial Paste:=xlPasteValues, Transpose:=True ' paste in currently referenced sheet

        sht2RngToCopy.Copy 'copy from the range previously defined in Sheet2
        .Range("E1").PasteSpecial Paste:=xlPasteValues + xlPasteFormats 'paste in currently referenced sheet

        .Name = "Good" ' name currently referenced sheet
    End With
End Sub

然后稍微更改您的“主”子，您可以按如下方式调用它：

Do While Filename <> ""
    'Call a subroutine here to operate on the just-opened workbook
    With Workbooks.Open(FolderPath & Filename) ' open and reference a new workbook
        add .Sheets.add ' call add passing it a reference to a new sheet in referenced workbook (i.e. the newly opened one)
        .Close True ' close referenced workbook saving changes
    End With
    Filename = Dir
Loop

循环遍历文件时（下标超出范围），VBA不起作用

3 个答案:

另见：