excel - VBA Excel-编译错误-属性无效使用

Question

我是全新的，这是我的第一个脚本。因此，在此先感谢您提供的任何帮助。

再过几天，我将收到我公司200多家分支机构的一系列调查。调查数据是在单个excel电子表格中收集的。

我正在尝试修改从Microsoft网站获得的脚本，该脚本遍历所有电子表格并将数据编译为单个电子表格。

我得到的错误是:编译错误:属性的无效使用

这是我的代码:

Sub MergeGTISurvey()
    Dim SurveySummary As Worksheet
    Set SurveySummary = Workbooks.Add(xlWBATWorksheet).Worksheets

    Dim FolderPath As String
    FolderPath = "C:\Users\dloots\mycompany\testsurveyfolder\"

    Dim NRow As Long
    NRow = 1

    Dim Filename As String
    Filename = Dir(FolderPath & "*.xl*")
    Do While Filename <> ""
        Dim WorkBk As Workbook
        Set WorkBk = Workbooks.Open(FolderPath & Filename)
        SurveySummary.Range("A" & NRow).Value = Filename

        Dim Sheet As Worksheets
        Set Worksheets = Sheet

        Dim SourceRange As Range
        Set SourceRange = WorkBk.Worksheets("Network").Range("B4:B16").Select

        Dim DestRange As Range
        Set DestRange = SurveySummary.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
        DestRange.Value = SourceRange.Value

        NRow = NRow + DestRange.Rows.Count

        WorkBk.Close savechanges:=False

        Filename = Dir()
    Loop

Answer 1

这是您代码的修改版本。您可以尝试一下。
您可能仍需要修改某些范围

Sub MergeGTISurvey()
    Dim SurveySummary As Workbook
    Set SurveySummary = Workbooks.Add(xlWBATWorksheet)

    Dim SurveySummarySheet As Worksheet
    Set SurveySummarySheet = SurveySummary.ActiveSheet


    Dim FolderPath As String
    FolderPath = "C:\Users\dloots\mycompany\testsurveyfolder\"

    Dim NRow As Long
    NRow = 1

    Dim Filename As String
    Filename = Dir(FolderPath & "*.xl*")
    Do While Filename <> ""
        Dim WorkBk As Workbook
        Set WorkBk = Workbooks.Open(FolderPath & Filename)
        SurveySummarySheet.Range("A" & NRow).Value = Filename

        Dim Worksht As Worksheet
        Set Worksht = WorkBk.Worksheets("Network")

        Worksht.Range("B4:B16").Copy
        SurveySummarySheet.Range("B" & CStr(NRow)).PasteSpecial

        ' This will get last row after paste
        NRow = SurveySummarySheet.Cells.SpecialCells(xlLastCell).Row + 1

        WorkBk.Close savechanges:=False

        Filename = Dir()
    Loop
End Sub