Question

我是全新的，我的第一个剧本EVER。所以，提前感谢您提供的任何帮助。

几天后，我将收到来自我公司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

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

1 个答案: