Excel 宏用新数据更新文件中的行
Excel Macro updating rows in a file with new data
下面的代码运行和执行完美，我只是想添加一些功能。该代码将新行从报告文件导入工作簿文件，我希望它通过行中的每个单元格检查具有新数据的潜在行，而不仅仅是 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:\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, "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
由于您似乎坚持比较两个范围：
'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
这是我的进展：
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:\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, "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
这会更新与 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:\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, "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
下面的代码运行和执行完美，我只是想添加一些功能。该代码将新行从报告文件导入工作簿文件，我希望它通过行中的每个单元格检查具有新数据的潜在行，而不仅仅是 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:\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, "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
由于您似乎坚持比较两个范围：
'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
这是我的进展：
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:\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, "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
这会更新与 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:\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, "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