Question

我在工作表 1（A 列）中有一个项目列表。表 1 中的每一项都有 5 个附加信息单元格（B 到 F）。表 2 有一些，甚至是表 1 中的大部分相同项目，但不是全部。我正在尝试编写一个程序，该程序将从工作表 2 开始，查看 A 列中的每个项目编号，然后检查工作表 1 中的相同编号。当它找到相同的数字时，它会从工作表 1 中复制 B 到 F 单元格信息，并将其放在工作表 2 中的项目编号旁边（B 到 F）。

我使用 For 循环尝试从 Sheet 2 单元格 A2 开始。尝试将变量 cSn 设置为 A2，然后循环遍历工作表 1，如果找到 cSn 将数据从工作表 1 复制到工作表 2。

为了查看程序是否正确运行，我添加了一个 MsgBox 来指示它何时找到。

程序似乎运行了，但不会复制数据并保留它。它似乎是复制数据，然后将其擦除，然后将工作表 1 最后一行的数据粘贴到工作表 2 的每一行上。我已经在此站点和其他站点上搜索了正确的复制/粘贴语法，但找不到它。我正在使用 MS Visual Basic 7.1。请帮忙！这是我目前所拥有的...

Sub CopyItemInfo()
    Dim cSn As String
    Sheets(1).Select
        FinalRow1 = Cells(Rows.Count, 1).End(xlUp).Row
    Sheets(2).Select
        FinalRow2 = Cells(Rows.Count, 1).End(xlUp).Row
    For x = 2 To FinalRow2
        cSn = Sheets(2).Range("A" & x)
        For y = 2 To FinalRow1
            If Sheets(1).Range("A" & y) = cSn Then MsgBox "Found One  " & cSn
                Worksheets(1).Range("B" & y).Copy Destination:=Worksheets(2).Range("B" & x)
                Worksheets(1).Range("C" & y).Copy Destination:=Worksheets(2).Range("C" & x)
                Worksheets(1).Range("D" & y).Copy Destination:=Worksheets(2).Range("D" & x)
                Worksheets(1).Range("E" & y).Copy Destination:=Worksheets(2).Range("E" & x)
                Worksheets(1).Range("F" & y).Copy Destination:=Worksheets(2).Range("F" & x)
                Application.ScreenUpdating = True
        Next y
    Next x
    Application.ScreenUpdating = True
 
End Sub

Answer 1

在IF里面的block之后，必须放End If，否则每一个循环都会执行这些行

For y = 2 To FinalRow1
            If Sheets(1).Range("A" & y) = cSn Then 
                MsgBox "Found One  " & cSn
                Worksheets(1).Range("B" & y).Copy Destination:=Worksheets(2).Range("B" & x)
                Worksheets(1).Range("C" & y).Copy Destination:=Worksheets(2).Range("C" & x)
                Worksheets(1).Range("D" & y).Copy Destination:=Worksheets(2).Range("D" & x)
                Worksheets(1).Range("E" & y).Copy Destination:=Worksheets(2).Range("E" & x)
                Worksheets(1).Range("F" & y).Copy Destination:=Worksheets(2).Range("F" & x)
                Application.ScreenUpdating = True
            End If ' add it
        Next y

Answer 2

更新工作表

提示

使用Option Explicit。
避免使用 Select。
限定对象（wb.worksheets...、sws.Range...、sws.Cells...）。
使用变量（Const、Dim）。
尽可能避免使用循环 (Application.Match)。

仍然可以通过将范围的值写入数组来改进它（在这个阶段太复杂了）。

Option Explicit

Sub CopyItemInfo()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(1)
    Dim sLast As Range: Set sLast = sws.Cells(sws.Rows.Count, 1).End(xlUp)
    Dim srg As Range: Set srg = sws.Range("A2", sLast)
    srg.Value = Application.Trim(srg) '***
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(2)
    Dim dLast As Range: Set dLast = dws.Cells(dws.Rows.Count, 1).End(xlUp)
    Dim drg As Range: Set drg = dws.Range("A2", dLast)
    
    Application.ScreenUpdating = False
    
    Dim dCell As Range
    Dim cIndex As Variant
    
    For Each dCell In drg.Cells
        cIndex = Application.Match(dCell.Value, srg, 0)
        If IsNumeric(cIndex) Then
            dCell.Offset(, 1).Resize(, 5).Value _
                = srg.Cells(cIndex).Offset(, 1).Resize(, 5).Value
        End If
    Next dCell
    
    Application.ScreenUpdating = True
 
End Sub

阵列版本（调整工作表）

Sub CopyItemInfoArray()

    Dim wb As Workbook: Set wb = ThisWorkbook

    Dim sws As Worksheet: Set sws = wb.Worksheets(1)
    Dim sLast As Range: Set sLast = sws.Cells(sws.Rows.Count, 1).End(xlUp)
    Dim srg As Range: Set srg = sws.Range("A2", sLast)
    srg.Value = Application.Trim(srg)
    Dim lData As Variant: lData = srg.Value
    Dim sData As Variant: sData = srg.Resize(, 6).Value

    Dim dws As Worksheet: Set dws = wb.Worksheets(2)
    Dim dLast As Range: Set dLast = dws.Cells(dws.Rows.Count, 1).End(xlUp)
    Dim drg As Range: Set drg = dws.Range("A2", dLast)
    Dim dData As Variant: dData = drg.Value
    ReDim Preserve dData(1 To UBound(dData, 1), 1 To 6)
    
    Dim r As Long, c As Long
    Dim cIndex As Variant

    For r = 1 To UBound(dData, 1)
        cIndex = Application.Match(dData(r, 1), lData, 0)
        If IsNumeric(cIndex) Then
            For c = 2 To 6
                dData(r, c) = sData(cIndex, c)
            Next c
        End If
    Next r
    
    drg.Resize(, 6).Value = dData

End Sub

Answer 3

您可以在没有 2 个循环的情况下完成此操作，并通过使用数组加快速度。

Option Explicit

Sub CopyItemInfo()
Dim rng As Range
Dim arrData1 As Variant
Dim arrData2 As Variant
Dim arrIDs As Variant
Dim idxCol As Long
Dim idxRow As Long
Dim Res As Variant

    With Sheets("Sheet1").Range("A1").CurrentRegion
        arrData1 = .Offset(1).Resize(.Rows.Count - 1).Value
        arrIDs = .Offset(1).Resize(.Rows.Count - 1).Columns(1).Value
    End With
    
    With Sheets("Sheet2").Range("A1").CurrentRegion
        Set rng = .Offset(1).Resize(.Rows.Count - 1).Resize(, 6)
    End With
    
    arrData2 = rng.Value
    
    For idxRow = LBound(arrData2, 1) To UBound(arrData2, 1)
        Res = Application.Match(arrData2(idxRow, 1), arrIDs, 0)
        If Not IsError(Res) Then
            For idxCol = LBound(arrData1, 2) To UBound(arrData2, 2)
                arrData2(idxRow, idxCol) = arrData1(Res, idxCol)
            Next idxCol
        End If
    Next idxRow
    
    
    rng.Value = arrData2
    
End Sub

使用 VBA 和 Excel 将项目数据从一张表复制到另一张表

3 个答案:

更新工作表