VBA Excel宏执行后无响应

问题描述

我正在尝试将数据从报告文件导入到我的工作簿文件中。还要自动对具有新数据的其他文件执行此操作，以便我可以更新工作簿文件中的行。该代码在执行后打开报告文件，但没有响应。

Sub Weekly_Report()
    Path = "C:\Users\Documents\Report"
    Filename = Dir(Report & "*.xlsx")
    do while Filename <> ""
    Workbooks.Open Filename:=Path & Report,ReadOnly:=True
    Loop
    Dim starting_row As Long
    header_exists = True 'If the file has a header and you don't want to import it,set this to True
    starting_row = 1
    If header_exists Then starting_row = 2

    Dim first_blank_row As Long
    first_blank_row = Cells.SpecialCells(xlCellTypeLastCell).Offset(1,0).Row 'Finds the last blank row

    Dim r As Long
    r = starting_row
    Dim Filenames As String
    Filenames = Path
    Dim found As Range
    Row = Workbooks(Filenames).ActiveSheet.Range("a" & r).Value
    do while Not Row = ""
        Set found = Columns("x:x").Find(what:=Row,LookIn:=xlValues,lookat:=xlWhole)
        If found Is nothing Then
            write_line_from_export Filenames,r,first_blank_row
            first_blank_row = first_blank_row + 1
        Else
            write_line_from_export Filenames,found.Row
        End If
        r = r + 1
        Row = Workbooks(Filenames).ActiveSheet.Range("a" & r).Value
        Loop
    End Sub
    
Sub write_line_from_export(Filenames As String,s As Long,d As Long)
    For e = 1 To 69
        Cells(d,e).Value = Workbooks(Filenames).ActiveSheet.Cells(s,e).Value
    Next e
End Sub

解决方法

尝试一下：

Sub Weekly_Report()
    Const HAS_HEADER As Boolean = True '<< use contants for fixed values
    Const NUM_COLS As Long = 69
    
    Dim Path,Filename,wbReport As Workbook,wsReport As Worksheet,m
    Dim wsData As Worksheet,next_blank_row As Long,r As Long,c As Range,rwStart As Long
    
    Path = "C:\Users\Documents\Report\"
    Filename = Dir(Path & "Report*.xlsx")   '???
    
    Set wsData = ThisWorkbook.Worksheets("Data") 'for example: destination worksheet
    next_blank_row = next_blank_row = wsData.Cells(Rows.Count,1).End(xlUp).Row + 1 'next blank row (edited)
    'make sure row is really empty...
    Do While Application.CountA(wsData.Rows(next_blank_row)) > 0
        next_blank_row = next_blank_row + 1
    Loop
    
    Do While Filename <> ""
    
        Set wbReport = Workbooks.Open(Path & Filename) '<< get a reference to the workbook
        Set wsReport = wbReport.Worksheets(1)          '<< assumes only one sheet
        rwStart = IIf(HAS_HEADER,2,1)
        
        For r = rwStart To wsReport.Cells(Rows.Count,1).End(xlUp).Row
            'Match is faster than Find
            m = Application.Match(wsReport.Cells(r,1).Value,wsData.Columns("X"),0)
            If IsError(m) Then
                m = next_blank_row 'no match - use next blank row and increment
                next_blank_row = next_blank_row + 1
            End If
            'don't go cell-by-cell
            wsData.Cells(m,1).Resize(1,NUM_COLS).Value = _
                     wsReport.Cells(r,NUM_COLS).Value
        Next r
        
        wbReport.Close False
        Filename = Dir()
    Loop

End Sub