Excel宏使用新数据更新文件中的行

Question

下面的代码运行和执行都很完美，我只想添加一些功能。该代码将新行从报表文件导入工作簿文件，我希望它按行中的每个单元格检查是否有潜在的具有新数据的行，而不仅仅是按列G(包含一个或多个用逗号分隔的数字(，而是按范围A2:BQ。还要更新新找到的单元格，即使工作簿中的行存在于G列中的数字。还要在工作簿文件中用明亮的颜色突出显示新行。最后一件事是在导入新单元格完成后包装文本。

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, "G").End(xlUp).Row + 1 'next blank row
sFilename = PATH & FILENAME
Debug.Print "Opening ", sFilename 'Openning file
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" 'If the file was not found or cannot be opened
Exit Sub
End If

Set wsReport = wbReport.Worksheets(1) 'Expects only one sheet in the Report
iStartRow = IIf(HAS_HEADER, 2, 1) 'If it has header start from row 2
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, "G").Value)
Set rng = wsData.Columns("A:BQ").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 'Match row:if the line already exists in the file
End If
wsData.Cells(m, 1).Resize(1, NUM_COLS).Value = wsReport.Cells(iRow, 1).Resize(1, NUM_COLS).Value 'Put the new line in Workbook

Next

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

Answer 1

这将更新与列G匹配的行的列p和S，或者在不匹配的情况下添加行。

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 cells in the row 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, "G").End(xlUp).Row + 1 'next blank row

sFilename = PATH & FILENAME
Debug.Print "Opening ", sFilename 'Openning file
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" 'If the file was not found or cannot be opened
Exit Sub
End If

Set wsReport = wbReport.Worksheets(1) 'Expects only one sheet in the Report
iStartRow = IIf(HAS_HEADER, 2, 1) 'If it has header start from row 2
iLastRow = wsReport.Cells(Rows.Count, 1).End(xlUp).Row

Dim rng As Range, rng2 As Range, rng3 As Range
Dim m As Long, m2 As String, m3 As String, s As String, s2 As String, s3 As String, c As Variant
Dim iAdd As Long, iUpdate As Long
For iRow = iStartRow To iLastRow

s = CStr(wsReport.Cells(iRow, "G").Value)
Set rng = wsData.Columns("G").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
With wsData.Cells(m, 1).Resize(1, NUM_COLS)
.Value = wsReport.Cells(iRow, 1).Resize(1, NUM_COLS).Value
.Interior.Color = vbYellow
End With
iAdd = iAdd + 1
Debug.Print iRow, s, "New row " & m

Else
m = rng.Row
For Each c In Array("P", "S")
If wsData.Cells(m, c) <> CStr(wsReport.Cells(iRow, c).Value) Then
wsData.Cells(m, c) = CStr(wsReport.Cells(iRow, c).Value)
wsData.Cells(m, c).Interior.Color = vbGreen
iUpdate = iUpdate + 1
End If
Next
Debug.Print iRow, s, "Match row " & m 'Match row:if the line already exists in the file

End If

Next

MsgBox wsReport.Name & " scanned from row " & iStartRow & _
" to " & iLastRow & vbCrLf & "added rows = " & iAdd & vbCrLf & _
"updated cells = " & iUpdate, vbInformation, sFilename
wbReport.Close False 'Close the Report
End Sub

Answer 2

由于您似乎一直在比较两个范围：

'Do two ranges contain the same value(s)?
'  does not handle error values...
Function RangesMatch(rng1 As Range, rng2 As Range) As Boolean
Dim rv As Boolean, v1, v2, r As Long, c As Long
If rng1.Rows.Count = rng2.Rows.Count And _
rng1.Columns.Count = rng2.Columns.Count Then

v1 = rng1.Value 
v2 = rng2.Value

If rng1.Count = 1 Then 
RangesMatch = (v1 = v2) 'single cell ranges...
Else
'multi-cell ranges: loop and compare values
For r = 1 To UBound(v1, 1)
For c = 1 To UBound(v1, 2)
If v1(r, c) <> v2(r, c) Then
Exit Function 'by default returns false
End If
Next c
Next r
RangesMatch = True
End If
End If
End Function

Answer 3

这就是我的进展：

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 cells in the row 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, "G").End(xlUp).Row + 1 'next blank row
sFilename = PATH & FILENAME
Debug.Print "Opening ", sFilename 'Openning file
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" 'If the file was not found or cannot be opened
Exit Sub
End If

Set wsReport = wbReport.Worksheets(1) 'Expects only one sheet in the Report
iStartRow = IIf(HAS_HEADER, 2, 1) 'If it has header start from row 2
iLastRow = wsReport.Cells(Rows.Count, 1).End(xlUp).Row

Dim s As String, rng As Range, m As Long, m2 As String, m3 As String, s2 As String, s3 As String, rng2 As Range, rng3 As Range
For iRow = iStartRow To iLastRow

s = CStr(wsReport.Cells(iRow, "G").Value)
Set rng = wsData.Columns("G").Find(s)
s2 = CStr(wsReport.Cells(iRow, "P").Value)
Set rng2 = wsData.Columns("P").Find(s2)
s3 = CStr(wsReport.Cells(iRow, "S").Value)
Set rng3 = wsData.Columns("S").Find(s3)

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 'Match row:if the line already exists in the file
m2 = rng2.Row
m3 = rng3.Row
End If
wsData.Cells(m, 1).Resize(1, NUM_COLS).Value = wsReport.Cells(iRow, 1).Resize(1, NUM_COLS).Value
wsData.Cells(m2, 1).Resize(1, NUM_COLS).Value = wsReport.Cells(iRow, 1).Resize(1, NUM_COLS).Value
wsData.Cells(m3, 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 'Close the Report
End Sub