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