问题描述
我试图基于X列将包含新数据的行从Report.xlsx文件导入到Workbook.xlsx文件，该列可以包含一个或多个用逗号分隔的数字。我只需要导入工作簿中尚未存在的行，其中包含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:\Users\Documents\" '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,NUM_COLS).Value
Next r
wbReport.Close False
Filename = Dir()
Loop
End Sub
解决方法
尝试使用Range.Find函数来代替MATCH。
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:\Users\Documents\" '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,"Match row " & m
End If
wsData.Cells(m,1).Resize(1,NUM_COLS).Value = wsReport.Cells(iRow,NUM_COLS).Value
Next
MsgBox wsReport.Name & " scanned from row " & iStartRow & _
" to " & iLastRow,vbInformation,sFilename
wbReport.Close False
End Sub