Seperate into different tabs depending on Cell content

kgkev

Well-known Member
Joined
Jun 24, 2008
Messages
1,285
Office Version
  1. 365
Platform
  1. Windows
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.
 
Last edited:

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Try this macro:
Code:
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
 
Upvote 0
**** 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
 
Upvote 0
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.

Code:
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
 
Upvote 0
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-com:eek:ffice:eek:ffice" /><o:p> </o:p>
Sheets("A").Range("B2:V" & Sheets("A").Rows.Count).ClearContents
 
Upvote 0
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?
 
Upvote 0
Change this line:<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
<o:p> </o:p>
Select Case Master.Cells(i, 10)<o:p></o:p>
<o:p> </o:p>
To this:<o:p></o:p>
<o:p> </o:p>
Select Case UCase(Master.Cells(i, 10))<o:p></o:p>
<o:p> </o:p>
This will make sure that it treats everything as upper case.<o:p></o:p>
 
Upvote 0
AdvancedFilter, AutoFilter will be the best though
Try this
Code:
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
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,150
Members
448,552
Latest member
WORKINGWITHNOLEADER

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top