VBA Excel将新行导入文件

Question

我正试图基于列X将带有新数据的行从Report.xlsx文件导入到我的Workbook.xlsx中，列X可以包含一个或多个用逗号分隔的数字。我只需要导入工作簿中没有的行，其中有69个单元格，可以包含数字和文本。我希望这个宏每周自动运行一次。该程序运行时没有任何问题，甚至在执行后打开和关闭Report文件，但不会导入行。

Sub Weekly_Report()
Const HAS_HEADER As Boolean = True 'Set true if the file has a header(Report)
Const NUM_COLS As Long = 69 '69 rows needed to be imported from the Report
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:UsersDocuments" 'path of the report
Filename = Dir(Path & "Report.xlsx")
Set wsData = ThisWorkbook.Worksheets("Sheet1") 'for example: destination worksheet
next_blank_row = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row + 1 'next blank row
Do While Filename <> ""
Set wbReport = Workbooks.Open(Path & Filename) 
Set wsReport = wbReport.Worksheets(1)          
rwStart = IIf(HAS_HEADER, 2, 1)

For r = rwStart To wsReport.Cells(Rows.Count, 1).End(xlUp).Row

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

Answer 1

作为MATCH的替代方法，请尝试Range.Find函数。

Option Explicit
Sub Weekly_Report()

Const HAS_HEADER As Boolean = True 'Set true if the file has a header(Report)
Const NUM_COLS As Long = 69 '69 rows needed to be imported from the Report
Const FILENAME = "Report.xlsx"
Const PATH = "C:UsersDocuments" 'path of the report

Dim wbReport As Workbook, wsReport As Worksheet, wsData As Worksheet
Dim next_blank_row As Long, iStartRow As Long, iLastRow As Long, iRow As Long
Dim sFilename As String

Set wsData = ThisWorkbook.Worksheets("Sheet1") 'for example: destination worksheet
next_blank_row = wsData.Cells(Rows.Count, "X").End(xlUp).Row + 1 'next blank row

sFilename = PATH & FILENAME
Debug.Print "Opening ", sFilename
On Error Resume Next

Set wbReport = Workbooks.Open(sFilename)
On Error GoTo 0
If wbReport Is Nothing Then
MsgBox "Can not open " & sFilename, vbCritical, "ERROR"
Exit Sub
End If

Set wsReport = wbReport.Worksheets(1)
iStartRow = IIf(HAS_HEADER, 2, 1)
iLastRow = wsReport.Cells(Rows.Count, 1).End(xlUp).Row

Dim s As String, rng As Range, m As Long
For iRow = iStartRow To iLastRow

s = CStr(wsReport.Cells(iRow, "X").Value)
Set rng = wsData.Columns("X").Find(s)

If rng Is Nothing Then
m = next_blank_row 'no match - use next blank row and increment
next_blank_row = next_blank_row + 1
Debug.Print iRow, s, "New row " & m
Else
m = rng.Row
Debug.Print iRow, s, "Match row " & m
End If
wsData.Cells(m, 1).Resize(1, NUM_COLS).Value = wsReport.Cells(iRow, 1).Resize(1, NUM_COLS).Value

Next

MsgBox wsReport.Name & " scanned from row " & iStartRow & _
" to " & iLastRow, vbInformation, sFilename
wbReport.Close False
End Sub