VBA to split data into multiple excel tabs

[ifvlookedup]

Hi all,

Thanks again advance for reading my post. I am a beginner at VBA/Macros so I am not sure how difficult my question is (hopefully simple!)

I currently have a macro that filters based on values in a column and then copy/pastes the corresponding rows to a new sheet based on that value. For example, if the column I filtered by had 4 unique values (Apples, Oranges, Pears, Peaches), it would create 4 new tabs in the same workbook but would copy/paste all corresponding rows to those values into their respective tab. This so far has been great and super helpful.

I am trying to take this one step further and only copy/paste select columns for certain values. For example, for "Oranges", I would only want columns C - F, I, and then J - Q copied over but for the rest of the values (Apples, Pears and Peaches), I would like it to continue doing what it is currently doing. I am sure this is possible but I just don't know where to begin. Below is the code that I currently use.

Any help would be greatly appreciated!!

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

    'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
    'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

    Application.ScreenUpdating = False
    vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="1", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 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 = 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) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        'Sheets(myarr(i) & "").Columns.AutoFit
    Next

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

 

[DanteAmor]

Try this. Change "Orages" for the name of your sheet.
Add a Case for another sheet if it requires different columns, see the "Bananas" example

Sub parse_data()
  Dim vcol As Variant, ky As Variant
  Dim c As Range, sh As Worksheet
  Dim lr As Long
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
  vcol = Application.InputBox("Which column would you like to filter by?", "Filter column", "1", Type:=1)
  If vcol = "" Or vcol = False Then Exit Sub
  
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Cells(Rows.Count, vcol).End(3).Row
  
  With CreateObject("Scripting.Dictionary")
    For Each c In sh.Range(sh.Cells(2, vcol), sh.Cells(lr, vcol))
      .Item(c.Value) = Empty
    Next c
    For Each ky In .Keys
      sh.Range("A1").AutoFilter vcol, ky
      On Error Resume Next
        Sheets(ky).Delete
      On Error GoTo 0
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      Select Case LCase(ky)
        Case LCase("Oranges")
          sh.AutoFilter.Range.Range("C1:F" & lr & ",I1:I" & lr & ",J1:Q" & lr).Copy Range("A1")
        Case LCase("Bananas")
          sh.AutoFilter.Range.Range("A1:D" & lr & ",J1:Q" & lr).Copy Range("A1")
        Case Else
          sh.AutoFilter.Range.EntireRow.Copy Range("A1")
      End Select
    Next ky
  End With
  sh.Select
  sh.ShowAllData

  Application.ScreenUpdating = True
End Sub

 

[ifvlookedup]

Try this. Change "Orages" for the name of your sheet.
Add a Case for another sheet if it requires different columns, see the "Bananas" example

Sub parse_data()
  Dim vcol As Variant, ky As Variant
  Dim c As Range, sh As Worksheet
  Dim lr As Long
 
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
 
  vcol = Application.InputBox("Which column would you like to filter by?", "Filter column", "1", Type:=1)
  If vcol = "" Or vcol = False Then Exit Sub
 
  Set sh = ActiveSheet
  If sh.AutoFilterMode Then sh.AutoFilterMode = False
  lr = sh.Cells(Rows.Count, vcol).End(3).Row
 
  With CreateObject("Scripting.Dictionary")
    For Each c In sh.Range(sh.Cells(2, vcol), sh.Cells(lr, vcol))
      .Item(c.Value) = Empty
    Next c
    For Each ky In .Keys
      sh.Range("A1").AutoFilter vcol, ky
      On Error Resume Next
        Sheets(ky).Delete
      On Error GoTo 0
      Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      Select Case LCase(ky)
        Case LCase("Oranges")
          sh.AutoFilter.Range.Range("C1:F" & lr & ",I1:I" & lr & ",J1:Q" & lr).Copy Range("A1")
        Case LCase("Bananas")
          sh.AutoFilter.Range.Range("A1:D" & lr & ",J1:Q" & lr).Copy Range("A1")
        Case Else
          sh.AutoFilter.Range.EntireRow.Copy Range("A1")
      End Select
    Next ky
  End With
  sh.Select
  sh.ShowAllData

  Application.ScreenUpdating = True
End Sub

This was unbelievably helpful. Thank you so much!!!!!!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[ifvlookedup]

I'm glad to help you. Thanks for the feedback.

Thanks again for your help on this-- much appreciated. I have 3 follow up questions that I hope should be simple to tackle. If not, no worries. You have already been super helpful! I have dropped what the macro looks like at the bottom.

1. I have multiple tabs in the sheet that do not interact with the macro. When I run the macro, it rearranges all of the tabs in an order that is not desirable. Is there a way to tell the macro to arrange the new tabs in the order I would like and to leave the other tabs that do not have anything to do with the macro grouped together at the end? Perhaps it doesn't need to tell the other tabs to do anything but I just need them to stay at the end versus having them all mixed up with the new tabs after I run the macro. Ideally, the filtered tabs would be ordered as such: "Active", "Complete", "Pending", "Cancelled"

2. Is there an easy way to tell the macro to format the text in the new tabs into the following - Font: Gotham; Font Size: 10, Font Color: Black.
Also this might be stretch but can it also shade a light gray for every other row? So the cadence would be white row, gray row, so on and so forth.

3. Lastly (and I understand if this is too much of a task), every time I run the macro, it recreates the tabs based on the column I am asking it to filter (I always filter the same column). Is there a way for the macro to continue to filter without having to replace or create a new tab every single time?

For example, can the "Complete" tab just pull any new information I am asking it to filter + update any corresponding rows from the sheet it is filtering without creating the same exact sheet as a new tab every single time I run the macro? I am fine with the macro erasing the contents in the "Complete" tab and replacing it each time it is run if that is an easy way to get this feature included. The purpose of this is to have a set of excel formulas live in the "Complete" worksheet so that every time I run the filter, the formulas remain there. Under the way it runs now, it erases everything that is manually added into the sheet.


Sub parse_data()
Dim vcol As Variant, ky As Variant
Dim c As Range, sh As Worksheet
Dim lr As Long

Application.DisplayAlerts = False
Application.ScreenUpdating = False

vcol = Application.InputBox("Which column would you like to filter by?", "Filter column", "1", Type:=1)
If vcol = "" Or vcol = False Then Exit Sub

Set sh = ActiveSheet
If sh.AutoFilterMode Then sh.AutoFilterMode = False
lr = sh.Cells(Rows.Count, vcol).End(3).Row

With CreateObject("Scripting.Dictionary")
For Each c In sh.Range(sh.Cells(2, vcol), sh.Cells(lr, vcol))
5465 .Item(c.Value) = Empty
Next c
For Each ky In .Keys
sh.Range("A1").AutoFilter vcol, ky
On Error Resume Next
Sheets(ky).Delete
On Error GoTo 0
Sheets.Add(, Sheets(Sheets.Count)).Name = ky
Select Case LCase(ky)
Case LCase("Active")
sh.AutoFilter.Range.Range("C1:H" & lr & ",Q1:Q" & lr & ",W1:X" & lr & ",AA1:AA" & lr & ",AD1:AG" & lr & ",AP1:AP" & lr & ",AZ1:AZ" & lr).Copy Range("A1")
Case LCase("Pending")
sh.AutoFilter.Range.Range("C1:H" & lr & ",AD1:AE" & lr & ",AG1:AG" & lr & ",BB1:BC" & lr & ",BG1:BG" & lr & ",BI1:BJ" & lr).Copy Range("A1")
Case LCase("Complete")
sh.AutoFilter.Range.Range("C1:H" & lr & ",AD1:AG" & lr & ",BB1:BG" & lr & ",BI1:BJ" & lr).Copy Range("A1")
Case LCase("Cancelled")
sh.AutoFilter.Range.Range("C1:H" & lr & ",W1:X" & lr & ",AA1:AA" & lr & ",AD1:AG" & lr).Copy Range("A1")
Case Else
sh.AutoFilter.Range.EntireRow.Copy Range("A1")
End Select
Next ky
End With
sh.Select
sh.ShowAllData