使用其他工作簿中的数据更新Excel工作簿中的数据
我有一个叫做价目表的工作簿,它包含几个工作表。每个工作表的格式相同,但包含不同的产品分类。工作表的格式如下所示: 1中华人民共和国说明单价 2个A001产品1个20.00 3 D001产品2 L 5.00 4 H001产品3 Rol 4.00 每个月我们都会收到一份更新的价格表作为Exel工作簿 在过去,我们获得了上述所有信息,但供应商发生了一些变化,我们只收到产品代码、条形码和价格 我需要通过将更新中的产品代码与价目表中的产品代码进行匹配来更新价目表。然后比较价格,如果价格不同,则应将价目表中的价格更改为更新的价格 如果可能,则应删除更新中的行,以便我们了解是否有新产品,如果更新中未找到产品代码,则应删除价格表中的行(对于停产产品) 更新包含大约12000行 有没有简单的方法 编辑以包含来自OP的注释和代码使用其他工作簿中的数据更新Excel工作簿中的数据,excel,vba,Excel,Vba,我有一个叫做价目表的工作簿,它包含几个工作表。每个工作表的格式相同,但包含不同的产品分类。工作表的格式如下所示: 1中华人民共和国说明单价 2个A001产品1个20.00 3 D001产品2 L 5.00 4 H001产品3 Rol 4.00 每个月我们都会收到一份更新的价格表作为Exel工作簿 在过去,我们获得了上述所有信息,但供应商发生了一些变化,我们只收到产品代码、条形码和价格 我需要通过将更新中的产品代码与价目表中的产品代码进行匹配来更新价目表。然后比较价格,如果价格不同,则应将价目表中
我写了一些代码,但我不熟悉VBA
Sub UpdateMisilanious_Original()
' UpdateMisilanious Macro
' This will update the misilanious List
'The variable for the active line in Misilanious
Dim ALMis As Integer
ALMis = 4
'The variable for the active line in Update
Dim ALUp As Integer
ALUp = 2
'The varible for product code of Misilanious
Dim PrCMis As String
'The varible for product code of Update
Dim PrCUp As String
'The temp Varible for the Price
Dim NewPrice As Currency
'Read the first Product code in Pricelist
PrCMis = Worksheets("Misilanious").Range("A" & ALMis).Value
'Start the Loop to update all Products
Do While PrCMis <> ""
PrCMis = Worksheets("Misilanious").Range("A" & ALMis).Value
PrCUp = Worksheets("Update").Range("A" & ALUp).Value
If PrCMis = PrCUp Then
'Copy price from Update to Pricelist
NewPrice = Worksheets("Update").Range("c" & ALUp).Value
Worksheets("Misilanious").Range("E" & ALMis) = NewPrice
'Add one to Active line of price list
ALMis = ALMis + 1
'Reset Active line of Update
ALUp = 2
Else:
'Loop through update untilmaching Product code is found
Do Until PrCMis = PrCUp
ALUp = ALUp + 1
PrCUp = Worksheets("Update").Range("A" & ALUp).Value
Loop
NewPrice = Worksheets("Update").Range("c" & ALUp).Value
Worksheets("Misilanious").Range("E" & ALMis) = NewPrice
'Add one to Active line of price list
ALMis = ALMis + 1
'Reset Active line of Update
ALUp = 2
End If
Loop
MsgBox "Update Done"
End Sub
编写代码的良好尝试,只是一个简短的评论: 如果产品停产,这部分将无休止地循环 下面提供的解决方案,循环遍历价目表中的产品,但它不会通过更新再次循环,而是找到匹配的记录。运行价目表与更新的比较,确定新的价格和停产产品,然后运行从更新到价目表的第二次比较,以添加新产品。看看下面的程序和建议的阅读资料,希望这能鼓励你继续努力,使那些单调重复的日常任务自动化 此解决方案使用以下三个工作表: 更新:包含所有产品的最新价格更新。它可能包括新产品,也不包括“停产”产品。其数据是从E7开始的连续单元格范围,由空白单元格分隔。 价目表:包含所有产品的列表以及相应的价格和其他相关数据。其数据是从C6开始的连续单元格范围,由空白单元格分隔。 已停产:包含已停产产品的列表。其数据是从B2开始的连续单元格范围,由空白单元格分隔。此工作表将由程序创建(如果不存在)。 此代码以两种方式运行价目表和更新工作表之间的产品比较,并更新新价格,在价目表数据中添加新产品和删除非连续产品,跟踪更新并在单独的工作表中保留非连续产品列表 由于此代码使用用户可能不知道的资源,因此我添加了一些关于其用途的指示,并建议使用页面进行扩展阅读和理解,不过请告诉我有关此代码的任何问题 ,, , , ,, , , ,, 图1更新前的价格表 图2更新数据 图3更新后的价格表
图4更新后中断我有以下想法:我有以下想法:读取价目表中A2的值保存为变量1。启动更新中A2的循环读取值并与变量1进行比较,如果=则读取更新中C2的值并存储在变量2中,并将变量2写入价目表的D2。然后删除更新中的第2行。如果更新中的A2不=变量1,则转到下一行读取A3并与变量1 extr进行比较。。如果读取值为False,表示无数据,则在价目表中的下一行结束循环并开始新循环。您对其工作原理的描述以及希望删除行的事实意味着使用VBA,但是您的问题被标记为excel公式。您是否打算使用VBA解决方案?如果是这样,请向我们展示您所做的工作以及您面临的问题。另一方面,在处理行时删除行,这将不允许在出现问题的情况下审核流程,但这同样与您希望使用的标准和质量级别有关。这可以用公式来完成,但是如果你坚持这样做的话,你必须手动删除行,或者用VBA。我写了一些代码,但我不熟悉VBA。现在我不知道如何前进,我想在这里复制代码,但它是为了longSub UpdateMilanious'UpdateMilanious Macro'这将更新misilanious列表'misilanious Dim ALMis中活动行的变量为整数ALMis=4'更新Dim ALUp中活动行的变量为整数ALUp=2'的产品代码变量Misilanious Dim PrCMis作为字符串“变量”
ible用于更新Dim PrCUp作为字符串的产品代码'The temp Variable for The Price Dim NewPrice As Currency谢谢你,你的代码运行良好,我将以此为基础学习更多VBA。很高兴知道这一点鼓励你,我们可以在此过程中帮助你,继续发布你的问题。。。
Sub UpdateMisilanious_Original()
' UpdateMisilanious Macro
' This will update the misilanious List
'The variable for the active line in Misilanious
Dim ALMis As Integer
ALMis = 4
'The variable for the active line in Update
Dim ALUp As Integer
ALUp = 2
'The varible for product code of Misilanious
Dim PrCMis As String
'The varible for product code of Update
Dim PrCUp As String
'The temp Varible for the Price
Dim NewPrice As Currency
'Read the first Product code in Pricelist
PrCMis = Worksheets("Misilanious").Range("A" & ALMis).Value
'Start the Loop to update all Products
Do While PrCMis <> ""
PrCMis = Worksheets("Misilanious").Range("A" & ALMis).Value
PrCUp = Worksheets("Update").Range("A" & ALUp).Value
If PrCMis = PrCUp Then
'Copy price from Update to Pricelist
NewPrice = Worksheets("Update").Range("c" & ALUp).Value
Worksheets("Misilanious").Range("E" & ALMis) = NewPrice
'Add one to Active line of price list
ALMis = ALMis + 1
'Reset Active line of Update
ALUp = 2
Else:
'Loop through update untilmaching Product code is found
Do Until PrCMis = PrCUp
ALUp = ALUp + 1
PrCUp = Worksheets("Update").Range("A" & ALUp).Value
Loop
NewPrice = Worksheets("Update").Range("c" & ALUp).Value
Worksheets("Misilanious").Range("E" & ALMis) = NewPrice
'Add one to Active line of price list
ALMis = ALMis + 1
'Reset Active line of Update
ALUp = 2
End If
Loop
MsgBox "Update Done"
End Sub
'Loop through update untilmaching Product code is found
Do Until PrCMis = PrCUp
ALUp = ALUp + 1
PrCUp = Worksheets("Update").Range("A" & ALUp).Value
Loop
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