VBA - copy cells from another sheet based on multiple criteria

Question

I'am new to VBA and got stuck real bad. I have two worksheets. I have to assign a sales person to every customer based on their address. On Sheet1 I use three data columns, Zip (K), City (I) and Country (L). On Sheet2 I have a Zip code range in column B and C (low and high value), the City (D) and the Country (E). In every row there is the name of the assigned sales person.

The requirements for the code: Check if customer's country matches with the first sales persons country. If yes check if customer's zip code is in range. If there is a match copy sales person name to Sheet1 and move to next row. If no Zip range is given on Sheet2 as criteria or there is no match on customer's zip, check if City matches, if there is a match copy sales person name to Sheet1 and move to next row. If no city is given on Sheet2 as criteria or there is no match on customer's city,check if country matches and copy sales persons name to Sheet1.

This is what if have so far:

`Sub Territory()
    Dim i As Integer
    Dim sh1 As Worksheet, sh2 As Worksheet
   Dim sh1Rws As Long, sh1Rng As Range, s1 As Range
   Dim sh2lowRws As Long, sh2lowRng As Range, s2l As Range
   Dim sh2highRws As Long, sh2highRng As Range, s2h As Range

   Set sh1 = Sheets("Sheet1")
   Set sh2 = Sheets("Sheet2")
   Set i = 1
   With sh1
        sh1Rws = .Cells(Rows.Count, "K").End(xlUp).Row
        Set sh1Rng = .Range(.Cells(1, "K"), .Cells(sh1Rws, "K"))
    End With

    With sh2l
        sh2lowRws = .Cells(Rows.Count, "B").End(xlUp).Row
        Set sh2lowRng = .Range(.Cells(1, "B"), .Cells(sh2lowRws, "B"))
    End With
    With sh2h
        sh2highRws = .Cells(Rows.Count, "C").End(xlUp).Row
        Set sh2highRng = .Range(.Cells(1, "C"), .Cells(sh2highRws, "C"))
    End With

    For Each s1 In sh1Rng
        For Each s2l In sh2lowRng
            If s1 > s2l And s1 < s2h Then sh2lowRws.Copy       Destination:=Sheet.sh1.Range("u", i)
            End If
            Set i = i + 1

    End Sub`

Both of your loops aren't getting closed and your End If isn't required - that's the most obvious errors from what I can see... Other than that, it's impossible to help because you haven't actually said what is wrong with the code and where the errors occur — SierraOscar
Also don't use Set when assigning basic variables such as integers (see set i = ...). The Set keyword is used only when assigning object references. — A.S.H
Set sh1 = Sheets("Sheet1") Set sh2 = Sheets("Sheet2") With sh1 sh1Rws = .Cells(Rows.Count, "I").End(xlUp).Row Set sh1Rng = .Range(.Cells(1, "I"), .Cells(sh1Rws, "I")) End With With sh2l sh2Rws = .Cells(Rows.Count, "D").End(xlUp).Row Set sh2Rng = .Range(.Cells(1, "D"), .Cells(sh2Rws, "D")) End With For Each s1 In sh1Rng For Each s2 In sh2Rng If s1 = s2 Then MsgBox "Test" Next s2 Next s1 End Sub — László Ádám Katona
Thank you for taking a look at this!! It won't show the right format...(or I can't use the site :) ). I get Run time error 424 for this code. What I can't impelemt: copy the row which contains the matched criteria and create an the criteria for the zip verification — László Ádám Katona

Apurv Pawar Apurv Pawar · Accepted Answer · 2017-03-20T14:51:43

Try the below code and let me know if it works or changes required

Sub test()
i = Sheets(1).Range("a1048576").End(xlUp).Row
l = Sheets(2).Range("a1048576").End(xlUp).Row

    For k = 2 To i
        For x = 2 To l
        CityCus = Sheets(1).Range("I" & k).Value
        CitySales = Sheets(2).Range("D" & x).Value

        CotyCus = Sheets(1).Range("L" & k).Value
        CotySales = Sheets(2).Range("E" & x).Value

        ZipCus = Sheets(1).Range("K" & k).Value
        ZipUpperSales = Sheets(2).Range("B" & x).Value
        ZiplowerSales = Sheets(2).Range("C" & x).Value

        c = Sheets(1).Range("b" & k).Value
        d = Sheets(2).Range("A" & x).Value

            If CotyCus = CotySales Then
                If CityCus = CitySales Then

                     If ZipCus <= ZiplowerSales And ZipCus >= ZipUpperSales Then

                       Sheets(1).Range("b" & k).Value = Sheets(2).Range("A" & x).Value
                     End If
                End If
             End If
        Next
    Next
End Sub

VBA - copy cells from another sheet based on multiple criteria

1 Answers