Question

我有一个名为“价目表”的工作簿，它包含多个工作表，每个工作表的格式相同但包含不同的产品分类。工作表的格式如下：

 A          B          C      D
1 PRC DESCRIPTION单位价格

2 A001产品1每20.00

3 D001 Product2 L 5.00

4 H001 Product3 Rol 4.00

每个月我们都会将更新的价目表作为Exel工作簿。

过去我们获得了上述所有信息，但在供应商处发生了变化，我们只收到了＆＃34;产品代码＆＃34; ＆＃34;条形码＆＃34;和＆＃34;价格＆＃34;

我需要通过将＆＃34;更新＆＃34; 中的产品代码与一个产品代码相匹配来更新我的＆＃34; Price-list＆＃34; 在我的价目表中。然后比较价格，如果价格不同，它应该将＆＃34;价格列表＆＃34; 中的价格更改为＆＃34;更新＆＃34;

如果可行，则应删除＆＃34;更新＆＃34; 中的行，以便我们知道是否有新产品并删除＆＃34; Price中的行-List＆＃34; 如果未在＆＃34;更新＆＃34;中找到产品代码，则对于已停产的产品。

＆＃34;更新＆＃34;包含大约12000行

这样做有简单的方法吗？

已包含来自OP的评论和代码

我写了一些代码但是我不想用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

Answer 1

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. 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:

Update: Contains the latest price update for all products. It may include new products, also “Discontinued” products are not included in this list. Its data is a continuous range of cells starting at E7, delimited by blank cells.
Price List: Contains the list of all products with respective price and other associated data. Its data is a continuous range of cells starting at C6, delimited by blank cells.
Discontinued: Contains the list of the discontinued products. Its data is a continuous range of cells starting at B2, delimited by blank cells. 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,

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

Fig.1 Price List before update

Fig.2 Update data

Fig. 3 Price list after update

Fig. 4 Discontinued after update

使用其他工作簿中的数据更新Excel工作簿中的数据

1 个答案: