1

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

我使用 For Loops 尝试从 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
4

3 回答 3

0

更新工作表

提示

  • 使用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
于 2021-04-14T19:40:57.010 回答
0

在里面的块之后IF，必须放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
于 2021-04-14T19:21:28.147 回答
0

您可以在没有 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
于 2021-04-14T19:45:54.337 回答