How to search for multiple strings in VBA and move them to another sheet-CodePudding

I'm trying to search in an Excel-file for EU-countries and place the rows in another sheet. It worked previously with 3 countries (although it showed only one of the entries per country) but now that I added all 50 countries it doesn't work at all. Does anyone has an idea how to fix that?

The table looks like this: Picture of table

Sub FindEU()


Dim MyAr(1 To 50)    As String
Dim oRng             As Range
Dim fRng             As Range
Dim i                As Long


MyAr(1) = "Albania" ' string to find
MyAr(2) = "Andorra" ' string to find
MyAr(3) = "Armenia" ' string to find
MyAr(4) = "Austria" ' string to find
MyAr(5) = "Azerbaijan" ' string to find
MyAr(6) = "Belarus" ' string to find
MyAr(7) = "Belgium" ' string to find
MyAr(8) = "Bosnia and Herzegovina" ' string to find
MyAr(9) = "Bulgaria" ' string to find
MyAr(10) = "Croatia" ' string to find
MyAr(11) = "Cyprus" ' string to find
MyAr(12) = "Czech Republic" ' string to find
MyAr(13) = "Denmark" ' string to find
MyAr(14) = "Estonia" ' string to find
MyAr(15) = "Finland" ' string to find
MyAr(16) = "France" ' string to find
MyAr(17) = "Georgia" ' string to find
MyAr(18) = "Germany" ' string to find
MyAr(19) = "Greece" ' string to find
MyAr(20) = "Hungary" ' string to find
MyAr(21) = "Iceland" ' string to find
MyAr(22) = "Ireland" ' string to find
MyAr(23) = "Italy" ' string to find
MyAr(24) = "Kazakhstan" ' string to find
MyAr(25) = "Latvia" ' string to find
MyAr(26) = "Liechtenstein" ' string to find
MyAr(27) = "Lithuania" ' string to find
MyAr(28) = "Luxembourg" ' string to find
MyAr(29) = "Malta" ' string to find
MyAr(30) = "Moldova" ' string to find
MyAr(31) = "Monaco" ' string to find
MyAr(32) = "Montenegro" ' string to find
MyAr(33) = "Netherlands" ' string to find
MyAr(34) = "North Macedonia" ' string to find
MyAr(35) = "Norway" ' string to find
MyAr(36) = "Poland" ' string to find
MyAr(37) = "Portugal" ' string to find
MyAr(38) = "Romania" ' string to find
MyAr(39) = "Russia" ' string to find
MyAr(40) = "San Marino" ' string to find
MyAr(41) = "Serbia" ' string to find
MyAr(42) = "Slovakia" ' string to find
MyAr(43) = "Slovenia" ' string to find
MyAr(44) = "Spain" ' string to find
MyAr(45) = "Sweden" ' string to find
MyAr(46) = "Switzerland" ' string to find
MyAr(47) = "Turkey" ' string to find
MyAr(48) = "Ukraine" ' string to find
MyAr(49) = "United Kingdom" ' string to find
MyAr(50) = "Vatican City" ' string to find
Set oRng = Worksheets("Sheet1").Columns(4) ' column to search

Set fRng = oRng.Cells(oRng.Cells.Count)
For i = 1 To Application.CountIf(oRng, MyAr(50) & "*")
    Set fRng = oRng.Cells.Find(What:=MyAr(i), _
                               LookIn:=xlValues, _
                               LookAt:=xlPart, _
                               After:=fRng, _
                               MatchCase:=False)
    If Not fRng Is Nothing Then
        With Worksheets("Sheet2") ' Output Sheet
            .Cells(i, "A") = fRng.Offset(0, -3).Value2 ' email
            .Cells(i, "B") = fRng.Offset(0, -2).Value2 ' firstname
            .Cells(i, "C") = fRng.Offset(0, -1).Value2 ' lastname
            .Cells(i, "D") = fRng.Offset(0, 0).Value2 ' country
        End With
    End If
Next i


End Sub

CodePudding user response：

I find it easiest to filter on the values you're looking for and then copy over the filtered rows. This code also assumes you want to override any data that was previously in your destination sheet (since you didn't specify and your original code would also override)

Sub FindEU()
    
    'Create array of strings to find
    Dim MyAr(1 To 50) As String
    MyAr(1) = "Albania"
    MyAr(2) = "Andorra"
    MyAr(3) = "Armenia"
    MyAr(4) = "Austria"
    MyAr(5) = "Azerbaijan"
    MyAr(6) = "Belarus"
    MyAr(7) = "Belgium"
    MyAr(8) = "Bosnia and Herzegovina"
    MyAr(9) = "Bulgaria"
    MyAr(10) = "Croatia"
    MyAr(11) = "Cyprus"
    MyAr(12) = "Czech Republic"
    MyAr(13) = "Denmark"
    MyAr(14) = "Estonia"
    MyAr(15) = "Finland"
    MyAr(16) = "France"
    MyAr(17) = "Georgia"
    MyAr(18) = "Germany"
    MyAr(19) = "Greece"
    MyAr(20) = "Hungary"
    MyAr(21) = "Iceland"
    MyAr(22) = "Ireland"
    MyAr(23) = "Italy"
    MyAr(24) = "Kazakhstan"
    MyAr(25) = "Latvia"
    MyAr(26) = "Liechtenstein"
    MyAr(27) = "Lithuania"
    MyAr(28) = "Luxembourg"
    MyAr(29) = "Malta"
    MyAr(30) = "Moldova"
    MyAr(31) = "Monaco"
    MyAr(32) = "Montenegro"
    MyAr(33) = "Netherlands"
    MyAr(34) = "North Macedonia"
    MyAr(35) = "Norway"
    MyAr(36) = "Poland"
    MyAr(37) = "Portugal"
    MyAr(38) = "Romania"
    MyAr(39) = "Russia"
    MyAr(40) = "San Marino"
    MyAr(41) = "Serbia"
    MyAr(42) = "Slovakia"
    MyAr(43) = "Slovenia"
    MyAr(44) = "Spain"
    MyAr(45) = "Sweden"
    MyAr(46) = "Switzerland"
    MyAr(47) = "Turkey"
    MyAr(48) = "Ukraine"
    MyAr(49) = "United Kingdom"
    MyAr(50) = "Vatican City"
    
    Dim wb As Workbook:     Set wb = ActiveWorkbook
    Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("Sheet1")
    Dim wsDst As Worksheet: Set wsDst = wb.Worksheets("Sheet2")
    Dim rData As Range:     Set rData = wsSrc.Range("A1").CurrentRegion
    Dim rDest As Range:     Set rDest = wsDst.Range("A2")
    
    rDest.CurrentRegion.Offset(1).ClearContents 'Clear previous results
    
    With rData
        'Filter column D for the countries
        .AutoFilter 4, MyAr, xlFilterValues
        
        'Copy and paste values to destination sheet
        .Offset(1).Copy
        rDest.PasteSpecial xlPasteValues
        
        'Remove filter
        .AutoFilter
    End With
    
End Sub