使用其他工作簿中的數據更新Excel工作簿中的數據

Question

我有一本名為“價格表”的工作簿，它包含幾個工作表，每個工作表的格式相同，但是包含不同的產品分類。 工作表的格式如下：

  ABCD 
1中國描述單位價格

2 A001產品1每個20.00

3 D001產品2 L 5.00

4 H001產品3 Rol 4.00

每個月，我們都會獲得一份更新的價目表作為Exel工作簿。

過去，我們獲得了上述所有信息，但是在供應商處發生了一些變化，我們只收到“產品代碼”，“條形碼”和“價格”

我需要通過將“更新”中的產品代碼與我的價格列表中的產品代碼相匹配來更新“價格表” 。 然后比較價格，如果價格不同，則應將“價格列表”中的價格更改為“更新”中的價格

如果可能，應刪除“更新”中的行，以便我們知道是否有新產品，如果在“更新”中未找到產品代碼，則請刪除“價目表”中的行。

“更新”包含大約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

編寫代碼的好嘗試，只需簡短評論一下：

如果產品停產，則該零件將無限循環……

'Loop through update untilmaching Product code is found
Do Until PrCMis = PrCUp
    ALUp = ALUp + 1
    PrCUp = Worksheets("Update").Range("A" & ALUp).Value
Loop

下面提供的解決方案在價目表中循環瀏覽產品，而不是在Update中循環瀏覽，而是找到匹配的記錄。 對“ 價格表”與“ 更新”進行比較，以識別新價格和停產的產品，然后對“ 更新”和“ 價格表”進行第二次比較，以添加新產品。 請查看下面的過程和建議的閱讀材料，希望這會鼓勵您繼續進行所有繁瑣而重復的日常任務自動化。

此解決方案使用以下三個工作表：

更新：包含所有產品的最新價格更新。 它可能包括新產品， “停產”產品也不包括在此列表中。 它的數據是從E7開始的連續單元格范圍， 由空白單元格分隔 。
價格表 ：包含所有產品的清單以及相應的價格和其他相關數據。 它的數據是從C6開始的連續單元格范圍， 由空白單元格分隔 。
停產的 ：包含停產產品的列表。 它的數據是從B2開始的連續單元格范圍， 由空白單元格分隔 。 如果不存在，將通過該過程創建該工作表。

此代碼對價格表和更新工作表之間的產品進行比較（兩種方式），並更新新價格 ，添加新產品和刪除價格表數據中的停產產品 ，並跟蹤更新並保留停產產品的列表在單獨的工作表中。

由於此代碼使用了用戶可能不知道的資源，因此，我添加了一些有關其用途的指示，並建議了一些頁面以供進一步閱讀和理解，不過，讓我知道您可能對代碼有任何疑問。

應用對象（Excel）， For ... Next語句， MsgBox函數，

范圍對象（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

圖1更新前的價目表

圖2更新數據

圖3更新后的價目表

圖4更新后停產

使用其他工作簿中的數據更新Excel工作簿中的數據

問題描述

1 個解決方案

解決方案1
0 已采納 2015-10-29 15:44:05

使用其他工作簿中的數據更新Excel工作簿中的數據

問題描述

1 個解決方案

解決方案1 0 已采納 2015-10-29 15:44:05

解決方案1
0 已采納 2015-10-29 15:44:05