Copying row of data from table into other sheet if cell matches criteria VBA

[AEla]

Good afternoon,
I have this table of data, and i would like to be able to copy each row of data into another sheet depending on the country name.
So if the country is Belgium for example, it would automatically go through the whole table (if data is added in the future) and take all the rows where the country is Belgium and paste them into another sheet named "Belgium". I would like to do this for every country.
What kind of VBA code would allow me to do so?


Please let me know if you can help.
Best regards,

 

[mumps]

Do the individual country sheets already exist or does the macro have to create them?

 

[AEla]

Do the individual country sheets already exist or does the macro have to create them?

They are already existing.

 

[mumps]

This macro assumes that the country sheets have headers in row 1 starting in cell A1. Change the name of the sheet (in red) to suit your needs.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant, srcWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    v = srcWS.Range("B2", srcWS.Range("B" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Sheets(v(i, 1)).UsedRange.Offset(1).ClearContents
                With srcWS
                    .Range("B1").CurrentRegion.AutoFilter 1, v(i, 1)
                    .AutoFilter.Range.Offset(1).Copy Sheets(CStr(v(i, 1))).Range("A2")
                End With
            End If
        Next i
    End With
    srcWS.Range("B1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[AEla]

This macro assumes that the country sheets have headers in row 1 starting in cell A1. Change the name of the sheet (in red) to suit your needs.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant, srcWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    v = srcWS.Range("B2", srcWS.Range("B" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                Sheets(v(i, 1)).UsedRange.Offset(1).ClearContents
                With srcWS
                    .Range("B1").CurrentRegion.AutoFilter 1, v(i, 1)
                    .AutoFilter.Range.Offset(1).Copy Sheets(CStr(v(i, 1))).Range("A2")
                End With
            End If
        Next i
    End With
    srcWS.Range("B1").AutoFilter
    Application.ScreenUpdating = True
End Sub

Thank you so much for you help and reply, however i am now getting an error message on the 'With create object("scripting dictionary")
Would you be able to help??
Best regards,

 

[mumps]

I just noticed that you are using a Mac and VBA for the Mac does not recognize Scripting Dictionaries. Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, LastRow As Long, srcRng As Range, country As Range
    Set srcWS = Sheets("Sheet1")
    With srcWS
        LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B1:G" & LastRow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set srcRng = .Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible)
        .ShowAllData
        For Each country In srcRng
            .Range("B1").CurrentRegion.AutoFilter 2, country
            .AutoFilter.Range.Offset(1).Copy Sheets(CStr(country)).Range("A2")
        Next country
        .Range("B1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub