[英]Copy and paste data from one a sheet to another sheet, and from second sheet to third using excel VBA
[英]Using VBA with Excel to Copy Item Data from One sheet to Another Sheet
我在工作表 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
在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
提示
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
您可以在没有 2 个循环的情况下执行此操作,并使用 arrays 加快速度。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.