VBA to copy rows from worksheet to multiple other worksheets based on cell data

[LFaz268710]

Hi,
I have a workbook that contains the details of customers booked for different trips on sheet 2

I want to copy the rows from sheet 2 to different sheets based on the location, e.g. all customers booked for Nice will copy to sheet 3, all for Mallorca will go to sheet 4 etc.

Is a VBA the only way to do this? I need to make sure it doesn't delete the data on sheet 2, but I'm struggling with the standard copy code as I can't work out how to ensure each additional sheet only pulls the particular location over. Do I have to have a VBA module for each location?

Many thanks,

 

[LFaz268710]

Yes that's correct - the owner of the business has to data cleanse these items so they will eventually have the correct format.

 

[mumps]

The macro is designed to look for the event name which includes the full date. Will you run the macro only after all the events contain the full date? If not, I need to know how you want to handle the events without a full date or with no date all as part of their name.

 

[LFaz268710]

The macro will run monthly, so new bookings will be added on a regular basis and then each month the macro will be run to update the location sheets.
It can skip over any that do not have the right criteria, as all rows need to remain on the CRM sheet but copy across to the location sheet if there is a match.

 

[mumps]

Try this macro.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, v As Variant, srcWS As Worksheet, dic As Object, key As Variant
    Set srcWS = Sheets("CRM")
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = srcWS.Range("D2", srcWS.Range("D" & srcWS.Rows.Count).End(xlUp)).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(v)
        If Not dic.Exists(v(i, 1)) Then
            dic.Add v(i, 1), Nothing
        End If
    Next i
    For Each key In dic.keys
        With srcWS
            If Evaluate("isref('" & key & "'!A1)") Then
                .Range("A1").AutoFilter 4, key
               .AutoFilter.Range.Offset(1).Copy Sheets(key).Cells(Sheets(key).Rows.Count, "A").End(xlUp).Offset(1)
            End If
        End With
    Next key
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[LFaz268710]

Fabulous thank you so much

 

[mumps]

You are very welcome.