Seperate into different tabs depending on Cell content

[kgkev]

I have a list of sales enquiries 1600 rows long. Each has a brand recorded in cell J (from j4 above is headers)

I have 4 brands

A, B, C & D

I would like to copy the data from the master sheet into 4 tabs lables A, B, C & D depending on the brand recorded in J

Any help greatly appreciated.

 

[Lewiy]

Try this macro:

Dim Limit As Long, i As Long
Dim Master As Worksheet, a As Worksheet, b As Worksheet, c As Worksheet, d As Worksheet
Set Master = Sheets("Master")
Set a = Sheets("A")
Set b = Sheets("B")
Set c = Sheets("C")
Set d = Sheets("D")
Limit = Master.Cells(Rows.Count, 10).End(xlUp).Row
For i = 1 To Limit
    Select Case Master.Cells(i, 10)
        Case "A"
            Master.Rows(i).Copy Destination:=a.Rows(a.Cells(Rows.Count, 10).End(xlUp).Row + 1)
        Case "B"
            Master.Rows(i).Copy Destination:=b.Rows(b.Cells(Rows.Count, 10).End(xlUp).Row + 1)
        Case "C"
            Master.Rows(i).Copy Destination:=c.Rows(c.Cells(Rows.Count, 10).End(xlUp).Row + 1)
        Case "D"
            Master.Rows(i).Copy Destination:=d.Rows(d.Cells(Rows.Count, 10).End(xlUp).Row + 1)
    End Select
Next i
End Sub

 

[TFCJamieFay]

**** too slow!! Lewiy's looks better anyway!!

Sub Macro1()

Dim BrandA As String
Dim BrandB As String
Dim BrandC As String
Dim BrandD As String

BrandA = "Brand A"
BrandB = "Brand B"
BrandC = "Brand C"
BrandD = "Brand D"

MyDate = Range("E1").Value

Application.ScreenUpdating = False

Worksheets("Sales Enquires").Select
Columns("A:A").Select
For Each cell In Selection
If cell.Value = BrandA Then
cell.EntireRow.Copy
Worksheets("Brand A").Activate
Range("A65536").Select
Selection.End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
ElseIf cell.Value = BrandB Then
cell.EntireRow.Copy
Worksheets("Brand B").Activate
Range("A65536").Select
Selection.End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
ElseIf cell.Value = BrandC Then
cell.EntireRow.Copy
Worksheets("Brand C").Activate
Range("A65536").Select
Selection.End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
ElseIf cell.Value = BrandD Then
cell.EntireRow.Copy
Worksheets("Brand D").Activate
Range("A65536").Select
Selection.End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
End If
Next

Application.ScreenUpdating = True

End Sub

 

[kgkev]

i think I need to clear the old data so this can be run again and again.

Row A will always contain the header.

I had a go at my first bit of VBA but it didn't work.

Sheets(A).Select
Range(Cells(2, 1), Cells(Rows.Count, 22)).Clear
 
Sheets(B).Select
Range(Cells(2, 1), Cells(Rows.Count, 22)).Clear
 
Sheets(C).Select
Range(Cells(2, 1), Cells(Rows.Count, 22)).Clear
 
Sheets(D).Select
Range(Cells(2, 1), Cells(Rows.Count, 22)).Clear

I assumed

Sheets(A).Select
would select sheet A then

Range(Cells(2, 1), Cells(Rows.Count, 22)).Clear
Would clear from B1 to the end of the rows and 22 cells to the right

Which bit have I got wrong

 

[Lewiy]

You need to put quotes around the sheet name and there’s no need to select anything, it can all be done in one line:
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
Sheets("A").Range("B2:V" & Sheets("A").Rows.Count).ClearContents

 

[kgkev]

Rookie mistake!!!


Back to the original problem I have a problem with case sensitiveness.

One brand is BPole

but could be Bpole BPOLE bpole or any other combination.

Most are entered as BPOLE but my macro didn't find them as I put them all down as BPole.

How do I make it work so that it doesn't matter what the case is?

 

[Lewiy]

Change this line:<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o> </o>
Select Case Master.Cells(i, 10)<o></o>
<o> </o>
To this:<o></o>
<o> </o>
Select Case UCase(Master.Cells(i, 10))<o></o>
<o> </o>
This will make sure that it treats everything as upper case.<o></o>

 

[jindon]

AdvancedFilter, AutoFilter will be the best though
Try this

Sub test()
Dim a, i As Long, ii As Long, w, e, ws As Worksheet
With Sheets("Master")
    a = .Range("a1", .Cells.SpecialCells(11)).Value
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 5 To UBound(a,1)
        If Not .exists(a(i, 10)) Then
            ReDim w(1 To UBound(a,2), 1 To 1)
            For ii = 1 To UBound(a,2) : w(ii, 1) = a(i,ii) : Next
            .add a(i,10), w
        Else
            w = .item(a(i,10))
            ReDim Preserve w(1 To UBound(a,2), 1 To UBound(w,2) + 1)
            For ii = 1 To UBound(a,2) : w(ii, UBound(w,2)) = a(i,ii) : Next
            .item(a(i,10)) = w
        End If
    Next
    For Each e In .keys
        On Error Resume Next
        Set ws = Sheets(e)
        On Error GoTo 0
        If ws Is Nothing Then
            Set ws = Sheets.Add
            ws.Name = e
        End If
        w = .item(e)
        ws.Range("a" & Rows.Count).End(xlUp))(2) _
        .Resize(UBound(w,2), UBound(w,1)).Value = Application.Transpose(w)
        Set ws = Nothing
    Next
End With
End Sub

 

[kgkev]

Thanks Jindon - Lewiy solutions seems to work fine for my needs though.

What situations would your script be better - It does look far more impressive.

 

[jindon]

Sure, if you are already happy, don't worry about my code.