Split Data into Sheets Based on Column Data

[MattieP]

I am having a little bit of trouble trying to split out some data. The macro I built I used some code that I found and altered it a little bit to do what I need it to do. I have 2 columns specifically that I am trying to use as the identifier to split out this data onto different sheets. The first column I need it to split by is column 16 (P), named "Agent". There is one specific "Agent" named "Direct" that can have various different companies in the next column, 17 (Q), which is the "Company" column. When it splits them all out, I would like the name it is using to split them out by to be entered as the worksheet name and include the word "Size Breaks" after it. The sheet I have as the template to transfer it to each time is called "SBD", that way it will go into the same format every time.

The code I have so far is below, but for some reason, I can't figure out why it won't split it by Agent first, and then by Company if it is named Direct, so I am at a road block right now.

Sub SplitMFR()

Dim myarr As Variant
Dim vcol, i As Integer
Dim lr As Long
Dim cell As Range
Dim ws As Worksheet
Dim icol As Long
Dim Found As Range
Dim title As String
Dim titlerow As Integer
Dim wsMaster As Worksheet
Dim lastrow As Long
Dim header As Range, headers As Range

Application.ScreenUpdating = False
vcol = 17
Set ws = Sheets("Size Breaks")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:V1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Size Breaks"

For i = 3 To lr
On Error Resume Next

If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 1 To UBound(myarr)
' For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & " Size Breaks"
Else
Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & " Size Breaks").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit

Sheets("SBD").Visible = True
Set wsMaster = ThisWorkbook.Worksheets("SBD")
wsMaster.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = myarr(i) & " Size Breaks"

Dim ghcInt As Integer, copyRng As Range, pasteRng As Range, pRow As Integer
' choose row to paste into
pRow = 1


Set headers = Worksheets(myarr(i) & " Size Breaks").Range("A1:V1")

For Each header In headers

ghcInt = GetHeaderColumnSB(header.Value)

If ghcInt > 0 Then
Set copyRng = Range(header.Offset(1), header.Cells(Rows.Count, 1).End(xlUp))
Set pasteRng = Worksheets(myarr(i) & " Size Breaks").Cells(pRow + 1, ghcInt)

copyRng.Copy
pasteRng.Offset(1).PasteSpecial xlPasteValues
End If
Next


Sheets(myarr(i) & " Size Breaks").Select
Application.DisplayAlerts = False
Sheets(myarr(i) & " Size Breaks").Delete
Application.DisplayAlerts = True
Sheets("SBD").Visible = False

Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub


Function GetHeaderColumnSB(header As String) As Integer
Set headers = Worksheets(myarr(i) & " Size Breaks").Range("A1:V1")
GetHeaderColumnSB = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

 

[Fluff]

As you haven't given us much to go on, I've made a few assumptions.
But try this

Sub SplitData()

   Dim Cl As Range
   Dim Dic As Object
   Dim Ws As Worksheet
   Dim MsWs As Worksheet
   Dim Ky As Variant
   Dim Ky2 As Variant
   
   Set Ws = Sheets("Size Breaks")
   Set MsWs = Sheets("SBD")
   MsWs.Visible = xlSheetVisible
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Ws.Range("P2", Ws.Range("P" & Rows.Count).End(xlUp))
      If Not Dic.exists(Cl.Value) Then
         If Not Cl.Value = "Direct" Then
            Dic.Add Cl.Value, Nothing
         Else
            Dic.Add Cl.Value, CreateObject("scripting.dictionary")
            Dic(Cl.Value).Add Cl.Offset(, 1).Value, Nothing
         End If
      ElseIf Cl.Value = "Direct" Then
         If Not Dic(Cl.Value).exists(Cl.Offset(, 1).Value) Then Dic(Cl.Value).Add Cl.Offset(, 1).Value, Nothing
      End If
   Next

   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   For Each Ky In Dic.keys
      If Not Ky = "Direct" Then
         MsWs.Copy after:=Sheets(Sheets.Count)
         ActiveSheet.Name = Ky & " Size Breaks"
         Ws.Range("A1").AutoFilter 16, Ky
         Ws.Range("A1").CurrentRegion.SpecialCells(xlVisible).Copy
         Sheets(Ky & " Size Breaks").Range("A1").PasteSpecial
      Else
         For Each Ky2 In Dic(Ky)
            MsWs.Copy after:=Sheets(Sheets.Count)
            ActiveSheet.Name = Ky2 & " Size Breaks"
            Ws.Range("A1").AutoFilter 16, Ky
            Ws.Range("A1").AutoFilter 17, Ky2
            Ws.Range("A1").CurrentRegion.SpecialCells(xlVisible).Copy
            Sheets(Ky2 & " Size Breaks").Range("A1").PasteSpecial
         Next Ky2
      End If
   Next Ky
   Ws.AutoFilterMode = False
   MsWs.Visible = xlSheetHidden

End Sub

 

[MattieP]

Hi Fluff,

Thanks for your help here. I'm sorry if I was missing any information, what would help determine on the corrections here?

After running your code, I am receiving an error when it is trying to rename the active sheet to the variant Ky & " Size Breaks". It looks like the tab names are going to be too long (since it only does 31 characters), so I will have to come up with a way of shortening the name before having it add to the tab name. So I removed the "Size Breaks" addition to each tab name since they will be distinct enough to begin with. However, when it splits the Direct companies into it's own tab, it stops there. I can't seem to figure out in the Ky2 section (which I am guessing is supposed to be the Direct portion) why it won't break out by the different Company names in column 17.

 

[Fluff]

What error do you get & if you click debug, what line of code is highlighted in yellow?

 

[MattieP]

The error I get with the renaming the tab is that the character length needs to be 31 characters or less. I removed the & " Size Breaks" because I don't necessarily need that. I don't get any errors now, but the information going to the Direct tab isn't being split out and is just going onto one tab by itself.

 

[Fluff]

Does it have "Direct" in col P, or is it "Direct Sales" or something similar?
If it's "Direct" on its own, check for leading or trailing spaces.
Also there is a potential problem with the code, which I've corrected here

Sub SplitData()

   Dim Cl As Range
   Dim Dic As Object
   Dim Ws As Worksheet
   Dim MsWs As Worksheet
   Dim Ky As Variant
   Dim Ky2 As Variant
   
   Set Ws = Sheets("Size Breaks")
   Set MsWs = Sheets("SBD")
   MsWs.Visible = xlSheetVisible
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Ws.Range("P2", Ws.Range("P" & Rows.Count).End(xlUp))
      If Not Dic.exists(Cl.Value) Then
         If Not Cl.Value = "Direct" Then
            Dic.Add Cl.Value, Nothing
         Else
            Dic.Add Cl.Value, CreateObject("scripting.dictionary")
            Dic(Cl.Value).Add Cl.Offset(, 1).Value, Nothing
         End If
      ElseIf Cl.Value = "Direct" Then
         If Not Dic(Cl.Value).exists(Cl.Offset(, 1).Value) Then Dic(Cl.Value).Add Cl.Offset(, 1).Value, Nothing
      End If
   Next

   If Ws.AutoFilterMode Then Ws.AutoFilterMode = False
   For Each Ky In Dic.keys
      If Not Ky = "Direct" Then
         MsWs.Copy After:=Sheets(Sheets.Count)
         ActiveSheet.Name = Ky
         Ws.Range("A1").AutoFilter 16, Ky
         [COLOR=#0000ff]Ws.Range("A1").AutoFilter 17[/COLOR]
         Ws.Range("A1").CurrentRegion.SpecialCells(xlVisible).Copy
         Sheets(Ky).Range("A1").PasteSpecial
      Else
         For Each Ky2 In Dic(Ky)
            MsWs.Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Ky2
            Ws.Range("A1").AutoFilter 16, Ky
            Ws.Range("A1").AutoFilter 17, Ky2
            Ws.Range("A1").CurrentRegion.SpecialCells(xlVisible).Copy
            Sheets(Ky2).Range("A1").PasteSpecial
         Next Ky2
      End If
   Next Ky
   Ws.AutoFilterMode = False
   MsWs.Visible = xlSheetHidden

End Sub