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

Question

我开发了一个 Excel 工具 - 在（取消）选择多个选项后 - 向用户/员工显示向客户出售产品的正确价格。

用户使用的工作表（即“Particulier”）从其他几个工作表中检索数据；其中一张是需要每隔一段时间更新一次的价目表（即“Toestelprijzen Start”）：每周我都会收到一个新的价目表，其中包含新产品价格，我用它来更新 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 项）都有不同的价格，具体取决于在“Particulier”工作表中选择的选项。也就是说，这个价目表上的每个产品都有 31 个不同的价格。

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

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

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

但是，我只需要每个产品的价格一次（例如，产品 X 有黑色、白色、金色和粉红色，但产品 X 无论颜色如何，其价格都是相同的，所以我只需要复制 31 个价格在这 4 种颜色中的 1 列 D: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

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

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