编写代码的尝试很好，只是一个简短的评论：
如果产品停产，这部分将无限循环……
'Loop through update untilmaching Product code is found
Do Until PrCMis = PrCUp
ALUp = ALUp + 1
PrCUp = Worksheets("Update").Range("A" & ALUp).Value
Loop
下面提供的解决方案是遍历Price List中的产品，但不是再次遍历Update，而是找到匹配的记录。比较 Price List 与 Update，确定新价格和停产产品，然后从 Update 到 Price List 进行第二次比较 以添加新产品。看看下面的过程和建议的阅读材料，希望这将鼓励您继续致力于自动化所有这些繁琐和重复的日常任务。
此解决方案使用以下三个工作表：
-
更新：包含所有产品的最新价格更新。它可能包括新产品，“停产”产品也不包含在此列表中。它的数据是从
E7 开始的连续单元格范围，由空白单元格分隔。
-
价格列表：包含所有产品的列表以及相应的价格和其他相关数据。它的数据是从
C6 开始的连续单元格范围，由空白单元格分隔。
-
停产：包含停产产品的列表。它的数据是从
B2 开始的连续单元格范围，由空白单元格分隔。如果该工作表不存在，该工作表将由该过程创建。
此代码运行价格列表和更新工作表之间的产品比较（双向）并更新新价格，添加新产品 并删除 价格表 数据中的停产产品，跟踪更新并将停产产品列表保存在单独的工作表中。
由于此代码使用了用户可能不知道的资源，因此我添加了一些说明它们的用途和建议的页面以供扩展阅读和理解，但如果您对代码有任何疑问，请告诉我。
Application Object (Excel),
For...Next Statement,
MsgBox Function,
Range Object (Excel),
Variables & Constants,
With Statement,
Worksheets Object (Excel),
WorksheetFunction Object (Excel)
Option Explicit
Sub Update_Miscellaneous()
Rem Constants to Hold Starting Cell of Data Ranges (update as required)
'see [Variables & Constants]
Const kIniPlst As String = "C6"
Const kIniUpdt As String = "E7"
Const kIniDisc As String = "B2"
Rem Declare Objects as Variables
'see [Range Object (Excel)]
Dim rUpdt As Range, rMisc As Range, rDisc As Range
Rem Declare Process Variables
Dim sProd As String, dPric As Double, dPOld As Double
Dim Wsh As Worksheet, Rng As Range
Dim bProdUpdt As Byte, bPricUpdt As Byte
Dim bProd As Byte, bPric As Byte, bPOld As Byte, bPStt As Byte
Dim lRow0 As Long, lRow1 As Long, lNew As Long
Dim tTme As Date, sNow As String
Rem Application Settings To Improve Performance
'see [Application Object (Excel)]
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Rem Set Time & Date
tTme = Now
sNow = Format(Now, " dd-mmm-yy hh:mm")
Rem Set Objects
'see [With Statement]
With ThisWorkbook
Set rUpdt = .Worksheets("Update").Range(kIniUpdt).CurrentRegion
Set rMisc = .Worksheets("Price List").Range(kIniPlst).CurrentRegion
On Error GoTo WshAdd
Set rDisc = .Worksheets("Discontinued").Range(kIniDisc).CurrentRegion
On Error GoTo 0
Set rDisc = rDisc.Rows(1).Offset(rDisc.Rows.Count)
End With
Rem Set Field Position - Updated
'see [WorksheetFunction Object (Excel)]
With rUpdt
Rem Set Field Position
'Using Excel Worksheet Functions in VBA
bProdUpdt = WorksheetFunction.Match("Product Code", .Rows(1), 0)
'Can also be used with Application
bPricUpdt = Application.Match("Price", .Rows(1), 0)
Rem Set Body Range
Set rUpdt = .Offset(1, 0).Resize(-1 + .Rows.Count)
End With
Rem Set Field Position - Miscellaneous
With rMisc
Rem Set AutoFilter Off
If Not .Worksheet.AutoFilter Is Nothing Then .AutoFilter
Rem Set Field Position
bProd = WorksheetFunction.Match("PRC", .Rows(1), 0)
bPric = WorksheetFunction.Match("PRICE", .Rows(1), 0)
bPOld = WorksheetFunction.Match("Price.Old", .Rows(1), 0)
bPStt = WorksheetFunction.Match("Status", .Rows(1), 0)
Rem Set Body Range
Set rMisc = .Offset(1, 0).Resize(-1 + .Rows.Count)
End With
Rem Update Current Products
With rMisc
Rem Set Latest Price
'see [For...Next Statement]
For lRow0 = 1 To .Rows.Count
sProd = .Cells(lRow0, bProd).Value2
dPOld = .Cells(lRow0, bPric).Value2
Rem Get Latest Price
lRow1 = 0
On Error Resume Next
lRow1 = WorksheetFunction.Match(sProd, rUpdt.Columns(bProdUpdt), 0)
On Error GoTo 0
If lRow1 <> 0 Then
Rem Prices Comparison
dPric = rUpdt.Cells(lRow1, bPricUpdt).Value2
If dPric <> dPOld Then
Rem New Price
.Cells(lRow0, bPOld).Value = dPOld
.Cells(lRow0, bPric).Value = dPric
.Cells(lRow0, bPStt).Value = "Price Change" & sNow
End If
Else
Rem Product Discontinued
.Cells(lRow0, bPOld).Value = dPOld
.Cells(lRow0, bPric).ClearContents
.Cells(lRow0, bPStt).Value = "Discontinued" & sNow
End If: Next: End With
Rem Set New Products
lNew = rMisc.Rows.Count
With rUpdt
For lRow0 = 1 To .Rows.Count
sProd = .Cells(lRow0, bProd).Value2
dPric = .Cells(lRow0, bPricUpdt).Value2
Rem Get New Product
lRow1 = 0
On Error Resume Next
lRow1 = WorksheetFunction.Match(sProd, rMisc.Columns(bProdUpdt), 0)
On Error GoTo 0
If lRow1 = 0 Then
Rem Add New Product
lNew = 1 + lNew
With rMisc
.Cells(lNew, bProd).Value = sProd
.Cells(lNew, bPric).Value = dPric
.Cells(lNew, bPStt).Value = "!New Product" & sNow
End With: End If: Next: End With
Rem Reset Range Misc
If lNew <> rMisc.Rows.Count Then
Set rMisc = rMisc.CurrentRegion
Set rMisc = rMisc.Offset(1, 0).Resize(-1 + rMisc.Rows.Count)
Debug.Print xlPasteFormats, Now,
rMisc.Rows(1).Copy
rMisc.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Debug.Print Now
End If
Rem Move Discontinued Records
With rMisc
Rem Sort By Status
'Sort is a Property of the Worksheet Object
With .Worksheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rMisc.Columns(bPStt), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rMisc
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rem Set AutoFilter
.CurrentRegion.AutoFilter
Rem Filter by Status\Discontinued
.AutoFilter Field:=bPStt, Criteria1:="=*Discontinued*"
On Error Resume Next
Set Rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Rem Set AutoFilter Off
If Not .Worksheet.AutoFilter Is Nothing Then .AutoFilter
Rem Work with Discontinued Records
If Not Rng Is Nothing Then
Rem Add Discontinued Records
rDisc.Resize(Rng.Rows.Count).Value = Rng.Value2
rDisc.CurrentRegion.Columns.AutoFit
Application.Goto rDisc.Worksheet.Cells(1), 1
Application.Goto rDisc.Cells(1)
Rem Delete Discontinued Records
'Rng.EntireRow.Delete 'Use this line if no other data in worksheet
Rng.Delete Shift:=xlUp 'Use this line if there is other data in worksheet
End If: End With
Rem Sort Remaining Records By Product
With rMisc.Worksheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rMisc.Columns(bProd), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rMisc
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rem Restate Application Settings
Application.Goto rMisc.Worksheet.Cells(1), 1
Application.Goto rMisc.Cells(1)
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'see [MsgBox Function]
Rem Process Completed
MsgBox "Update Completed in " & Format(Now - tTme, "hh : mm : ss.001"), _
vbApplicationModal + vbInformation + vbOKOnly, _
"Product Price Update"
Exit Sub
WshAdd:
'see [Worksheets Object (Excel)]
Rem Add Worksheet Discontinued
With ThisWorkbook
Set Wsh = .Sheets.Add(After:=.Sheets(.Sheets.Count))
End With
Wsh.Name = "Discontinued"
Wsh.Range(kIniDisc).Resize(, rMisc.Columns.Count).Value = rMisc.Rows(1).Value2
Resume
End Sub
图1更新前的价目表
图2更新数据
图。 3 更新后的价目表
图。 4 更新后停产