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

Question

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

我使用For Loops尝试在第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内的块之后，必须放置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

您可以在没有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

Answer 3

更新工作表

提示

• 使用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