Using VBA with Excel to Copy Item Data from One sheet to Another Sheet

Question

I have a list of items in Sheet 1 (column A). Each item in sheet 1 has 5 cells of additional information (B thru F). Sheet 2 has some, even most of the same items at Sheet 1, but NOT ALL. I am trying to write a program that will start in Sheet 2, look at each item number in the A column, then check sheet 1 for the same number. When it finds the same number it will copy the B thru F cell information from sheet 1 and place it next to the items number in sheet 2 (B thru F).

I used For Loops to attempt to start on Sheet 2 cell A2. Attempted to set variable cSn to A2, then Loop thru Sheet 1 and if it finds cSn to copy data from sheet 1 to sheet 2.

In an attempt to see if the program was running correctly, I added a MsgBox to indicate when it found one.

The program seems to run, but wont copy the data and leave it. It appears to copy the data, then erase it, then paste the data on the last row of sheet 1 onto every line on sheet 2. I've searched this site and others for the correct Copy/Paste Syntax, but cant find it. I am using MS Visual Basic 7.1. Please Help! Here is what I have so far...

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

The nested loop is the issue, if you step through the code you'll see that it isn't copying what you think it is. Also all the copying is outside the `If` which I think it should be inside? — Warcupine, Apr 14 '21 at 19:20

score 0 · Answer 1 · answered Apr 14 '21 at 19:21

After the block inside the IF, you must put End If, otherwise all these lines are executed on each cycle

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

Thank you! I tried the End If, but kept getting a block error. I noticed you put a carriage return after "Then." That made it work. Thanks again! — rblackmon002, Apr 15 '21 at 12:20

VBasic2008 · Answer 2 · 2021-04-15T17:15:09.097

Update Worksheet

Tips

Use Option Explicit.
Avoid using Select.
Qualify objects (wb.worksheets..., sws.Range..., sws.Cells...).
Use variables (Const, Dim).
Avoid using loops when possible (Application.Match).

It can still be improved by writing the values of the ranges to arrays (too complicated at this stage).

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

The Array Version (adjust the worksheets)

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

Wow! This is MUCH faster. Thank you! Question? After running all (3) working programs, I noticed that some of my item numbers (computer generated from another program) have spaces at the end and manually entered number did not. Is there a way to use the "*" at the end to see both? Second Question? Rather than use Sheets(1) and Sheets(2), is there a way to say Active Sheet, and Sheet before Active sheet. Most of my file have only 2 sheets, but some have 3 or 4. I'm always working on the last sheet. — rblackmon002, Apr 15 '21 at 14:50
1. Is the `*`issue referring to source(s) or destination(d)? 2. `wb.Worksheets(wb.Worksheets.Count)` for the last, and `wb.Worksheets(wb.Worksheets.Count-1)` for the one before the last. — VBasic2008, Apr 15 '21 at 15:00
It would be the source. Some of the sheet(1) data is computer generated where the item number has an extra space at the end and some is manually input without a space. Sheet(2) would be all computer generated item numbers. Thanks for the answer to #2. I will update. — rblackmon002, Apr 15 '21 at 16:29
I gave it another thought and you can just add the line `srg.value = Application.Trim(srg)` below the lines `Dim srg As Range: Set srg = sws.Range("A2", sLast)`. — VBasic2008, Apr 15 '21 at 16:51

score 0 · Answer 3 · answered Apr 14 '21 at 19:45

You could do this without 2 loops and speed things up by using 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

Using VBA with Excel to Copy Item Data from One sheet to Another Sheet

3 Answers3

Update Worksheet