[英]Updating data in Excel workbook with data in an other workbook
I have a workbook Called Price list, it contain several worksheets each worksheet is in the same format but contain different classifications of products. 我有一本名为“价格表”的工作簿,它包含几个工作表,每个工作表的格式相同,但是包含不同的产品分类。 The format of a work sheet is as folows: 工作表的格式如下:
ABCD
1 PRC DESCRIPTION UNIT PRICE 1中国描述单位价格
2 A001 Product1 Each 20.00 2 A001产品1每个20.00
3 D001 Product2 L 5.00 3 D001产品2 L 5.00
4 H001 Product3 Rol 4.00 4 H001产品3 Rol 4.00
Every month We get an Updated Price List as an Exel workbook. 每个月,我们都会获得一份更新的价目表作为Exel工作簿。
In the past we got all the information as above but something changed at the Supplier and we only receive the "Product code" "Bar-code" and "Price" 过去,我们获得了上述所有信息,但是在供应商处发生了一些变化,我们只收到“产品代码”,“条形码”和“价格”
I need to update my "Price-list" by matching the Product Code in the "Update" with the one in my Price list. 我需要通过将“更新”中的产品代码与我的价格列表中的产品代码相匹配来更新“价格表” 。 Then compare price, if the price differs it should change the price in the "Price-list" to that of the "Update" 然后比较价格,如果价格不同,则应将“价格列表”中的价格更改为“更新”中的价格
If posible it should delete the line in the "Update" for us to know if there are new Products and delete the Line in the "Price-List" if the product code is not found in the "Update", For discontinued Products. 如果可能,应删除“更新”中的行,以便我们知道是否有新产品,如果在“更新”中未找到产品代码,则请删除“价目表”中的行。
The "Update" Contains about 12000 lines “更新”包含大约12000行
Is there an easy way in doing it? 有一个简单的方法吗?
EDITED TO INCLUDE COMMENTS AND CODE FROM OP 编辑以包含来自OP的注释和代码
I wrote some Code But I'm not to clued up with VBA. 我写了一些代码,但是我不打算使用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
Good attempt at writing the code, just a short comment about it: 编写代码的好尝试,只需简短评论一下:
This part will loop endlessly if the Product is discontinued… 如果产品停产,则该零件将无限循环……
'Loop through update untilmaching Product code is found
Do Until PrCMis = PrCUp
ALUp = ALUp + 1
PrCUp = Worksheets("Update").Range("A" & ALUp).Value
Loop
The solution provided below, loop through the products in the Price List but the instead of looping again through the Update , it finds the matching record. 下面提供的解决方案在价目表中循环浏览产品,而不是在Update中循环浏览,而是找到匹配的记录。 Runs a comparison of Price List vs. Update identifying new prices and discontinued products, then runs a second comparison from Update to Price List in order to add new products. 对“ 价格表”与“ 更新”进行比较,以识别新价格和停产的产品,然后对“ 更新”和“ 价格表”进行第二次比较,以添加新产品。 Have a look at the procedure below and the suggested readings, hope this will encourage you to continue working on automating all those tedious and repetitive daily tasks. 请查看下面的过程和建议的阅读材料,希望这会鼓励您继续进行所有繁琐而重复的日常任务自动化。
This solutions uses these three worksheets: 此解决方案使用以下三个工作表:
E7
, delimited by blank cells . 它的数据是从E7
开始的连续单元格范围, 由空白单元格分隔 。 C6
, delimited by blank cells . 它的数据是从C6
开始的连续单元格范围, 由空白单元格分隔 。 B2
, delimited by blank cells . 它的数据是从B2
开始的连续单元格范围, 由空白单元格分隔 。 This worksheet will be created by the procedure if not present. 如果不存在,将通过该过程创建该工作表。 This code runs a comparison of the Products between the Price List and Update worksheets (both ways) and updates new prices , adds new products and deletes discontinued products in the Price List data, with track of the updates and keeping a list of the discontinued products in a separated worksheet. 此代码对价格表和更新工作表之间的产品进行比较(两种方式),并更新新价格 ,添加新产品和删除价格表数据中的停产产品 ,并跟踪更新并保留停产产品的列表在单独的工作表中。
As this code use resources that might be unknown to the user, I have added some indications of their purpose and suggested pages for extended reading and understanding, nevertheless let me know of any question you might have about the code. 由于此代码使用了用户可能不知道的资源,因此,我添加了一些有关其用途的指示,并建议了一些页面以供进一步阅读和理解,不过,让我知道您可能对代码有任何疑问。
Application Object (Excel) , For...Next Statement , MsgBox Function , 应用对象(Excel) , For ... Next语句 , MsgBox函数 ,
Range Object (Excel) , Variables & Constants , With Statement , 范围对象(Excel) , 变量和常量 , 带有语句 ,
Worksheets Object (Excel) , WorksheetFunction Object (Excel) 工作表对象(Excel) , 工作表功能对象(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
Fig.1 Price List before update 图1更新前的价目表
Fig.2 Update data 图2更新数据
Fig. 3 Price list after update 图3更新后的价目表
Fig. 4 Discontinued after update 图4更新后停产
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.