Creating different sheets from data in the first sheet,

[Jo4x4]

Hi everybody! I have a very simple spreadsheet with all the data in sheet 1. I would like to split that data into different sheets. I tried vlookup, and can find the first match, but no second or third match.

Potholes	2/5/2017 <colgroup><col width="101" style="width:76pt"> </colgroup><tbody> </tbody>	John
Streetlights	8/6/ 2017	Peter
Water leaks	3/4/2017	Dave
Potholes	1/6/2017	Adam
Potholes	3/2/2017	Pete

<tbody>
</tbody>

I then want sheets named "Potholes", "Streetlights", "Water Leaks" with the Pothole sheet containing the 3 instances and names.


Thanks a stack in advance!

Jo

Windows 7, Excel 2007

 

[Fluff]

OK.
The problem was that A4 was blank, therefore it was trying to create a sheet with no name.

Sub ShtFltrCopy()

    Dim Dict As Object
    Dim Ky As Variant
    Dim Cl As Range
    Dim UsdRws As Long
    Dim Ws As Worksheet
    Dim x

Application.ScreenUpdating = False
Application.CopyObjectsWithCells = False

    Set Dict = CreateObject("scripting.dictionary")

    With Sheets("2017")
        UsdRws = .Range("A" & Rows.Count).End(xlUp).Row
    
        For Each Cl In .Range("A2:A" & UsdRws)
            If Not Dict.exists(Cl.Value) And Len(Cl.Value) > 0 Then Dict.Add Cl.Value, Nothing
        Next Cl
    
        For Each Ky In Dict.keys
            If ShtExists(Left(Ky, 31)) Then
                Set Ws = Sheets(Left(Ky, 31))
                Ws.Cells.Clear
                .Columns("A:I").Copy
                Ws.Columns("A:I").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone
                .Range("A1:I" & UsdRws).AutoFilter Field:=1, Criteria1:=Ky
                .Range("A1:I" & UsdRws).SpecialCells(xlVisible).Copy Ws.Range("A1")
                x = Ws.UsedRange
            Else
                Set Ws = Worksheets.Add(After:=Sheets(1))
                Ws.Name = Left(Ky, 31)
                .Columns("A:I").Copy
                Ws.Columns("A:I").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone
                .Range("A1:I" & UsdRws).AutoFilter Field:=1, Criteria1:=Ky
                .Range("A1:I" & UsdRws).SpecialCells(xlVisible).Copy Ws.Range("A1")
                x = Ws.UsedRange
            End If
        Next Ky
        .AutoFilterMode = False
    End With
    Sheets("2017").Activate
    
Application.CopyObjectsWithCells = True

End Sub

I've added a few tweaks.
It no longer copies the button to each sheet & it copies the column widths as well

 

[Jo4x4]

Hi Fluff, me again. I could only try it this morning. It is yellow highlighting the first line and then blue highlighting IF ShtExists.

Thanks
Jo

 

[mandukes]

Sorry, for chipping in but I couldn't help appreciating Fluff, I was looking for similar problem and I though it its not possible in vba, but the solution you provided was amazing..

looks like scripting.dictionary does wonders.

Fluff, could you please explain how your code works.. I'm not familiar with scripting.dictionary.

Thanks in advance

 

[Fluff]

@Jo4x4
Sounds like you have deleted this function, which needs to go in a standard module

Function ShtExists(ShtNme As String, Optional Wbk As Workbook) As Boolean

    If Wbk Is Nothing Then Set Wbk = ThisWorkbook
    On Error Resume Next
    ShtExists = (LCase(Wbk.Sheets(ShtNme).Name) = LCase(ShtNme))
    On Error GoTo 0

End Function

@mandukes
Have a look here for details about the dictionary
https://excelmacromastery.com/vba-dictionary/

 

[mumps]

Maybe you could give this a try:

Sub AddSheet()
    Application.ScreenUpdating = False
    Dim bottomA As Long
    bottomA = Sheets("2017").Range("A" & Rows.Count).End(xlUp).Row
    Dim problem As Range
    Dim ws As Worksheet
    Sheets("2017").Range("A1:A" & bottomA).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
        ("A1:A" & bottomA), Unique:=True
    Set rnguniques = Sheets("2017").Range("A2:A" & bottomA).SpecialCells(xlCellTypeVisible)
    If Sheets("2017").FilterMode Then Sheets("2017").ShowAllData
    For Each problem In rnguniques
        If problem <> "" Then
            Set ws = Nothing
            On Error Resume Next
            Set ws = Worksheets(problem.Value)
            On Error GoTo 0
            If ws Is Nothing Then
                Worksheets.Add(After:=Sheets(Sheets.Count)).Name = problem.Value
            End If
        End If
    Next problem
    For Each problem In Sheets("2017").Range("A2:A" & bottomA)
        If problem <> "" Then
            Sheets("2017").Range("A" & problem.Row & ":C" & problem.Row).Copy Sheets(problem.Value).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next problem
    Application.ScreenUpdating = True
 End Sub

 

[Jo4x4]

Thanks guys!!! Working like a charm. I am using Fluff's solution because it keeps "2017" in the sheet 1 position. But thanks a stack to Fluff and Mumps!

Jo

 

[Fluff]

Glad we could help & thanks for the feedback