Is this Easy? - VBA: Create Multiple Sheets from filtered data contained in a column

S

ShazzaBoom

New Member
Joined
Dec 1, 2015
Messages
6
Hi

I am a newbie to <acronym title="visual basic for applications">VBA</acronym> coding in Excel and this one is just too complex for me to get my head around so reaching out to this great forum I have had so much success with :smile:

If you could help by providing some <acronym title="visual basic for applications">VBA</acronym> code that will do the following:
Have a button that when clicked would create multiple tabs for all the various possibilities in the 'Beverage' column. I'm guessing we need to build an array but as I said I am a bit of a newbie and don't really understand arrays
i.e. A tab for 'Beer' and would include CustA/D/E
All Customer data that has 'Beer' would be copied to the new 'Beer' tab
Loop for next Beverage Type[TABLE="class: cms_table_grid, width: 300, align: left"]
<tbody>[TR]
[TD]Customer[/TD]
[TD]Country[/TD]
[TD]Beverage[/TD]
[/TR]
[TR]
[TD]CustA[/TD]
[TD]England[/TD]
[TD]Beer; Wine[/TD]
[/TR]
[TR]
[TD]CustB<strike></strike>[/TD]
[TD]Canada[/TD]
[TD]Cider; Whisky; Wine[/TD]
[/TR]
[TR]
[TD]CustC<strike></strike>[/TD]
[TD]Australia[/TD]
[TD]Cider[/TD]
[/TR]
[TR]
[TD]CustD<strike></strike>[/TD]
[TD]India[/TD]
[TD]Beer[/TD]
[/TR]
[TR]
[TD]CustE<strike></strike>[/TD]
[TD]USA[/TD]
[TD]Beer; Whisky[/TD]
[/TR]
</tbody>[/TABLE]



Initially I started thinking this wouldn't be too hard, but is more and more complex the more I look at it, or is it?
Hopefully a smart cookie or two can help me out

Thanks in advance
ShazzaBoom​
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Sort by date Sort by votes
Hi ShazzaBoom,

Does code below help?

Code: 
Sub Test()    
    Dim MyArray, MyArr
    Dim sString As String
    Dim vcol
    Dim lr As Long, lr2 As Long
    Dim ws As Worksheet
    Dim title As String
    
    Call SpeedOn
    
    'Items to array
    MyArray = Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row).Value
    
    'Split array by "; " and join it again by delimiter of ","
    MyArray = Join(Split(toArray2(Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)), "; "), ",")
    
    'Split by delimiter of ","
    MyArray = Split(MyArray, ",")
    
    '// Create a Dictory for Unquie Items
    
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    'Set d = New Scripting.Dictionary
    
    Dim i As Long
    For i = LBound(MyArray) To UBound(MyArray)
        d(MyArray(i)) = 1
    Next i
    
    'Write to Spreadsheet
    Range("F1") = "Unique Items"
    Range("F2").Resize(UBound(d.Keys) + 1, 1) = WorksheetFunction.Transpose(d.Keys)
    MyArr = Range("F2:F" & Cells(Rows.Count, 6).End(xlUp).Row).Value
    
    'Auto Filter
    vcol = 3
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:C1"
    
    'Filter & Copy Data by Beverage Type
    For i = 1 To UBound(MyArr)
        ws.AutoFilterMode = False
        ws.Range("A1:C6").AutoFilter Field:=vcol, Criteria1:="*" & MyArr(i, 1) & "*", Operator:=xlFilterValues
        
        If Not Evaluate("=ISREF('" & MyArr(i, 1) & "'!A1)") Then
            If WorksheetExists(CStr(MyArr(i, 1))) = True Then
                Sheets(MyArr(i, 1)).Delete
                Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i, 1) & ""
            Else
                Sheets(MyArr(i) & "").Move After:=Worksheets(Worksheets.Count)
            End If
        End If
        'ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(MyArr(i) & "").Range("A1")
        ws.Range("A" & title & ":A" & lr).Copy Sheets(MyArr(i, 1) & "").Range("A1")
        With Sheets(MyArr(i, 1) & "")
            lr2 = .Cells(.Rows.Count, vcol).End(xlUp).Row
            .Columns("F:F").Delete
            .Range("C2:C" & lr2) = MyArr(i, 1)
            .Columns.AutoFit
        End With
    Next
    
    'Tidy up
    With ws
    .AutoFilterMode = False
    .Activate
    .Columns("F:F").Delete
    End With
    
    Call SpeedOff
    
End Sub


Public Function toArray2(RNG As Range)
    Dim arr As Variant
    arr = RNG


    With WorksheetFunction
        If UBound(arr, 2) > 1 Then
            toArray2 = Join((.Index(arr, 1, 0)), ",")
        Else
            toArray2 = Join(.Transpose(.Index(arr, 0, 1)), ",")
        End If
    End With
End Function


'Returns True if sheet existss
Public Function WorksheetExists(WorksheetName As String, Optional wb As Workbook) As Boolean
    If wb Is Nothing Then Set wb = ThisWorkbook
    With wb
        On Error Resume Next
        WorksheetExists = (.Sheets(WorksheetName).Name = WorksheetName)
        On Error GoTo 0
    End With
End Function


Private Sub SpeedOn()
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = False 'Prevent screen flickering
        '.Calculation = xlCalculationManual 'Preventing calculation
        .DisplayAlerts = False 'Turn OFF alerts
        .EnableEvents = False 'Prevent All Events
    End With
End Sub
Private Sub SpeedOff()
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = True 'Prevent screen flickering
        '.Calculation = xlAutomatic 'Preventing calculation
        .DisplayAlerts = True 'Turn OFF alerts
        .EnableEvents = True 'Prevent All Events
    End With
End Sub

Biz
 
Upvote 0
Hi,
Sorry changed code slightly. Try the revised code.

Code: 
Sub Test()    Dim MyArray, MyArr
    Dim sString As String
    Dim vcol
    Dim lr As Long, lr2 As Long
    Dim ws As Worksheet
    Dim title As String
    
    Call SpeedOn
    
    'Items to array
    MyArray = Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row).Value
    
    'Split array by "; " and join it again by delimiter of ","
    MyArray = Join(Split(toArray2(Range("C2:C" & Cells(Rows.Count, 3).End(xlUp).Row)), "; "), ",")
    
    'Split by delimiter of ","
    MyArray = Split(MyArray, ",")
    
    '// Create a Dictory for Unquie Items
    
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    'Set d = New Scripting.Dictionary
    
    Dim i As Long
    For i = LBound(MyArray) To UBound(MyArray)
        d(MyArray(i)) = 1
    Next i
    
    'Write to Spreadsheet
    Range("F1") = "Unique Items"
    Range("F2").Resize(UBound(d.Keys) + 1, 1) = WorksheetFunction.Transpose(d.Keys)
    MyArr = Range("F2:F" & Cells(Rows.Count, 6).End(xlUp).Row).Value
    
    'Auto Filter
    vcol = 3
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:C1"
    
    'Filter & Copy Data by Beverage Type
    For i = 1 To UBound(MyArr)
        ws.AutoFilterMode = False
        ws.Range("A1:C6").AutoFilter Field:=vcol, Criteria1:="*" & MyArr(i, 1) & "*", Operator:=xlFilterValues
        
        If Not Evaluate("=ISREF('" & MyArr(i, 1) & "'!A1)") Then
            If WorksheetExists(CStr(MyArr(i, 1))) = True Then
                Sheets(MyArr(i, 1)).Delete
            Else
                Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i, 1) & ""
            End If
        End If
        ws.Range("A" & title & ":A" & lr).Copy Sheets(MyArr(i, 1) & "").Range("A1")
        With Sheets(MyArr(i, 1) & "")
            lr2 = .Cells(.Rows.Count, vcol).End(xlUp).Row
            .Columns("F:F").Delete
            .Range("C2:C" & lr2) = MyArr(i, 1)
            .Columns.AutoFit
        End With
    Next
    
    'Tidy up
    With ws
    .AutoFilterMode = False
    .Activate
    .Columns("F:F").Delete
    End With
    
    Call SpeedOff
    
End Sub


Public Function toArray2(RNG As Range)
    Dim arr As Variant
    arr = RNG


    With WorksheetFunction
        If UBound(arr, 2) > 1 Then
            toArray2 = Join((.Index(arr, 1, 0)), ",")
        Else
            toArray2 = Join(.Transpose(.Index(arr, 0, 1)), ",")
        End If
    End With
End Function




'Returns True if sheet existss
Public Function WorksheetExists(WorksheetName As String, Optional wb As Workbook) As Boolean
    If wb Is Nothing Then Set wb = ThisWorkbook
    With wb
        On Error Resume Next
        WorksheetExists = (.Sheets(WorksheetName).Name = WorksheetName)
        On Error GoTo 0
    End With
End Function


Private Sub SpeedOn()
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = False 'Prevent screen flickering
        '.Calculation = xlCalculationManual 'Preventing calculation
        .DisplayAlerts = False 'Turn OFF alerts
        .EnableEvents = False 'Prevent All Events
    End With
End Sub
Private Sub SpeedOff()
    'Speeding Up VBA Code
    With Application
        .ScreenUpdating = True 'Prevent screen flickering
        '.Calculation = xlAutomatic 'Preventing calculation
        .DisplayAlerts = True 'Turn OFF alerts
        .EnableEvents = True 'Prevent All Events
    End With
End Sub
 
Upvote 0
Thank you for your feedback. Your question was challenging and also made me think outside box.
Biz
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Using VBA to loop through multiple Word Templates and fill them in with Excel Data
2
Replies
14
Views
1K
John_w
J
SkywardPalm
  • Question Question
Populate blank cells based on column values from multiple sheets, using Item Number and column headers
Replies
1
Views
794
SkywardPalm
SkywardPalm
C
  • Question Question
Complex VBA code - Multiple IF conditions including Worksheet Name contains text partially matching Cell
Replies
1
Views
3K
celebwen_orn
C
S
  • Question Question
VBA: How to Create Multiple Sheets from filtered data contained in a column
Replies
0
Views
520
ShazzaBoom
S
J
  • Question Question
Multiple Substitute from list in VBA
Replies
0
Views
3K
jsturm
J

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

Share this page

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