Question

我开发了一个Excel工具 - 在（de）选择几个选项之后 - 向用户/员工显示将产品销售给客户的正确价格。

用户使用的工作表（即＆＃34; Particulier＆＃34;）从其他几张纸张中检索数据;这些表中的一个是价格表（即＃34; Toestelprijzen Start＆＃34;），需要每隔一段时间更新一次：每周我都会收到一个新的价格表，其中包含我用来更新旧产品的新产品价格Excel工具中的价格。为此，我使用以下完全正常的代码：

Sub ImportPrijslijstStart()
    Dim sImportFile As String, sFile As String
    Dim sThisBk As Workbook
    Dim vfilename As Variant
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sThisBk = ActiveWorkbook
    sImportFile = Application.GetOpenFilename( _
    FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook")
    If sImportFile = "False" Then
        MsgBox "No File Selected!"
        Exit Sub
    Else
        vfilename = Split(sImportFile, "\")
        sFile = vfilename(UBound(vfilename))
        Application.Workbooks.Open Filename:=sImportFile

        Set wbBk = Workbooks(sFile)
        With wbBk
            If SheetExists("VF Start incl. BTW") Then
                Set wsSht = .Sheets("VF Start incl. BTW")
                wsSht.Copy before:=sThisBk.Sheets("Toestelprijzen Start")
            Else
                MsgBox "Er is geen sheet met de naam VF Start incl. BTW in:"&vbCr& .Name
            End If
            wbBk.Close SaveChanges:=False
        End With
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Prijslijst geïmporteerd"
End Sub

Private Function SheetExists(sWSName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sWSName)
    If Not ws Is Nothing Then SheetExists = True
End Function

此新进口价目表上的每件商品（350件商品）具有不同的价格，具体取决于在＆＃34; Particulier＆＃34;工作表。也就是说，此价格表上的每个产品都有31种不同的价格。

前2列（A＆amp; B）显示产品编号，第3列（C）显示产品名称，列D：AH显示产品价格。接下来，标题在第1-6行，产品价格从第7行开始。因此，这个新的导入工作表在单元格A1：AH357中有数据，其中单元格D7：AH357显示产品价格。

但是，有时会添加新产品，旧产品会从新价格表中删除，这意味着第357行并不总是最后一行。接下来，我想将这个新导入的工作表中的价格复制（即＆＃34;更新＆＃34;）到具有旧价格的工作表。

我将价格从新工作表复制到旧工作表，因为在这个新的价目表中，会有多次显示不同颜色的产品。每种颜色都显示为具有唯一产品编号的独特产品，但每种颜色的价格相同。

但是，我只需要每个产品的价格一次（例如，产品X有黑色，白色，金色和粉色，但产品X的价格是相同的，无论颜色如何，所以我只需要复制31个价格在D列中：这4种颜色中的1种是AH。为此，我使用VLOOKUP搜索旧价目表和新价目表中使用的唯一产品编号。

但是，我的代码不能按我想要的方式工作。它只复制一列，而不是31列D：AH。此外，它复制所有信息两次;也就是说，它成功搜索并查找（复制）第一列（D）中的值（价格）从新导入的价格表到具有旧价格（更新价格）的表单，例如，从第7行到第87行（只有80行，因为有80个项目具有唯一的产品编号），但随后，它将第88行的所有数据（价格）粘贴到第168行。

此外，运行代码时需要大约40秒才能完成。我完全不知道为什么我的代码：

仅从一列而不是31列复制数据
两次粘贴数据
需要很长时间才能完成

我正在寻求帮助来解决这三个问题。

请在下面找到我使用的代码：

Sub PrijslijstUpdatenStart()
    Dim Osh As Worksheet
    'Sheet with the new product prices:
    Set Osh = ThisWorkbook.Sheets("VF Start incl. BTW") 
    Dim Orange As String
    Dim Olength As Integer
    Olength = Osh.Range("B1", Osh.Range("B7").End(xlDown)).Rows.Count
    Orange = "B7:AH" & Olength    
    Dim Nsh As Worksheet
    'Sheet on which the old prices are displayed that need to be updated with the 
    '   new prices on "VF Start incl. BTW":
    Set Nsh = ThisWorkbook.Sheets("Toestelprijzen Start") 
    Dim Nrange As String
    Dim Nlength As Integer
    Nlength = Nsh.Range("B1", Nsh.Range("B10").End(xlDown)).Rows.Count
    Nrange = "B10:AG" & Nlength
    On Error Resume Next
    Dim Dept_Row As Long
    Dim Dept_Clm As Long
    Table1 = Nsh.Range(Nrange)
    Table2 = Osh.Range(Orange)
    Dept_Row = Nsh.Range("E10:AH" & Olength).Row
    Dept_Clm = Nsh.Range("E10:AH" & Olength).Column
    For Each cl In Table1
        Nsh.Cells(Dept_Row, Dept_Clm) = _
                  Application.WorksheetFunction.VLookup(cl, Table2, 2, False)
        Dept_Row = Dept_Row + 1
    Next cl
End Sub

我试图尽可能清楚地描述情况。如果您需要更多信息，请告诉我。

Answer 1

这里我使用Dictionary将产品名称作为键存储，将新值作为数组存储在第一个工作表中。然后，我遍历第二个工作表，找到匹配项后，将值数组分配给相邻的列。

Sub PrijslijstUpdatenStart()
    Application.ScreenUpdating = False
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Sheets("VF Start incl. BTW")
        For Each r In .Range("B7", .Range("B7").End(xlDown))
            If Not dict.Exists(r.Value) Then dict.Add r.Value, r.Offset(0, 1).Resize(1, 31).Value
        Next
    End With

    With ThisWorkbook.Sheets("Toestelprijzen Start")
        For Each r In .Range("B10", .Range("B10").End(xlDown))
            If dict.Exists(r.Value) Then r.Offset(0, 1).Resize(1, 31).Value = dict(r.Value)
        Next
    End With
    Application.ScreenUpdating = True
End Sub

更新：删除新价目表中缺少的旧产品。

Sub PrijslijstUpdatenStart()
    Application.ScreenUpdating = False
    Dim x As Long
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With ThisWorkbook.Sheets("VF Start incl. BTW")
        For Each r In .Range("B7", .Range("B7").End(xlDown))
            If Not dict.Exists(r.Value) Then dict.Add r.Value, r.Offset(0, 1).Resize(1, 31).Value
        Next
    End With

    With ThisWorkbook.Sheets("Toestelprijzen Start")
        For x = .Range("B10").End(xlDown).Row To 10 Step -1
            If dict.Exists(.Cells(x, "B").Value) Then
                .Cells(x, "C").Offset(0, 1).Resize(1, 31).Value = dict(.Cells(x, "C").Value)
            Else
                .Rows(x).Delete
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

如何将多个（但不是全部）行和列中的单元格值从一个工作表复制到另一个工作表

1 个答案: