CODEWITHSUNDEEP
excelvbaexcel-formula
Akire
Akire

Reputation: 169

VBA is stopping before it is done

I have a problem...

I have two datasets in the same workbook on different sheets. The first column in both datasets are identifiers. In Sheet1 I have my dataset, and want to fill it with data from Sheet2 (which is also containing data (rows+Columns) that I do not want to use.

I have a VBA that is working, BUT, it stops before it is done. E.g. I have 1598 Rows in Sheet2, but it stops working already after 567 rows..

Sub Test()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = ActiveWorkbook.Worksheets("Sheet2")
    Set Target = ActiveWorkbook.Worksheets("Sheet1")

    j = 2    
    For Each c In Source.Range("A2", Source.Range("A" & Source.Cells(Source.Rows.Count, "A").End(xlUp).Row))
        If c = Target.Cells(j, 1).Value Then
           Source.Range("D" & c.Row & ":AS" & c.Row).Copy Target.Cells(j, 26) 
           j = j + 1
        End If
    Next c
    MsgBox "Done"
End Sub

Can someone help me and see if there is something obviously wrong with the code? I have tried it on smaller datasets, and then it works perfect. If more information needed or you have some other tips, please ask/tell :D

Thanks!

Upvotes: 1

Views: 52

Answers (1)

Pᴇʜ
Pᴇʜ

Reputation: 57743

VBA Solution

Try the following, it usese the WorksheetFunction.Match method to properly match the values of column A no matter which order they are.

It loops through all rows in Target, and tries to find a matching row in Source. If a match was found it copies it into the Target.

Option Explicit

Public Sub Test()
    Dim Source As Worksheet
    Set Source = ThisWorkbook.Worksheets("Sheet2")

    Dim Target As Worksheet
    Set Target = ThisWorkbook.Worksheets("Sheet1")


    Dim LastRowTarget As Long
    LastRowTarget = Target.Cells(Target.Rows.Count, "A").End(xlUp).Row

    Dim tRow As Long
    For tRow = 2 To LastRowTarget
        Dim sRowMatch As Double
        sRowMatch = 0 'reset match row
        On Error Resume Next 'ignore if next line throws error
        sRowMatch = Application.WorksheetFunction.Match(Target.Cells(tRow, 1).Value, Source.Columns("A"), 0)
        On Error GoTo 0 're-enable error reporting

        If sRowMatch <> 0 Then 'if matching does not find anything it will be 0 so <>0 means something was found to copy
            Source.Range("D" & sRowMatch & ":AS" & sRowMatch).Copy Target.Cells(tRow, 26)
        End If
    Next tRow

    MsgBox "Done"
End Sub

Formula Solution

Note that there is no need for VBA and this could actually also solved with formulas only. Either the VLOOKUP formula or a combination of INDEX and MATCH formula.

So in Sheet1 cell Z2 write =INDEX(Sheet2!D:D,MATCH($A2,Sheet2!$A:$A, 0)) and pull it down and right.

Upvotes: 1

Related Questions