VBA Excel 宏执行后无响应

Question

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

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, r, 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

Answer 1

试试这个：

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, 1).Resize(1, NUM_COLS).Value
        Next r
        
        wbReport.Close False
        Filename = Dir()
    Loop

End Sub

VBA Excel 宏执行后无响应

VBA Excel Macro not responding after execution

excel

vba

ms-office