Adjusting Macros-Question

[saduff]

Good Morning,

I have been utilzing this macro for some time and trying to change to the best of my ability as years go by and as my main "directoy" tab changes. I know enough about macros to be dangerous and really screw this up! I am creating new tabs from the "T" column in the "Directory" tab. For some reason, it appears that all of my rows in the directory tab are not reading and coming thru each of the macros-created tabs. Everything in the "T" tab is correct.

Would someone assist looking at the macro and see what's going wrong?

Thank you in advance!

Sub TestCleanedUP()
'This macro creates a new worksheet for each village name in Column F of the 'Directory' sheet when
'it is ran. It will then copy over the applicable columns from the active sheet to the appropriate
'new sheets columns.
'CAUTION: As written, this macro First DELETES all sheets that aren't named 'Directory'.
'If instead, you wish it to continue adding onto existing worksheets, you'll need to remove
'the commented snippet.

Dim wsSource As Worksheet
Dim lOutputRow As Long
Dim i As Long
Dim lr As Long
Dim sVillageCode As String
Dim ws As Worksheet

Set wsSource = Worksheets("directory")


Application.ScreenUpdating = False
'For now, I put in a "Delete all sheets but Directory" remove this snippet if needed.
For Each ws In Worksheets
If LCase(ws.Name) <> "directory" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws

lr = wsSource.Range("F" & wsSource.Rows.Count).End(xlUp).Row

For i = 2 To lr
'I'm assuming that the village names/initials are case-insensitive, but could have
'leading or trailing spaces.
sVillageCode = Trim(UCase(wsSource.Range("T" & i)))

'Check to see if a village code is listed. If it isn't, we'll just put it into a sheet called
'Unknown Village
If Trim(sVillageCode) = "" Then sVillageCode = "Unknown Village"
'check to see if there's currently a sheet with that villages name. If not, then create a sheet and
'put in the headers.
If Not WorksheetExists(sVillageCode) Then
Call CreateSheetWithHeaders(sVillageCode)
End If
'find the currently last used row on the ouput sheet, and add one to place stuff in the right spot
lOutputRow = Worksheets(sVillageCode).Range("F" & Worksheets(sVillageCode).Rows.Count).End(xlUp).Row + 1

'I personally like to avoid using copy and paste in code, unless I'm messing around with fancy cell formatting...
'Also, The output sheets columns don't match up with a simple copy/paste.
'we'll need to Explicitly say which column in the output sheet comes from which input sheet.
Worksheets(sVillageCode).Range("A" & lOutputRow) = wsSource.Range("B" & i)
Worksheets(sVillageCode).Range("B" & lOutputRow) = wsSource.Range("D" & i)
Worksheets(sVillageCode).Range("C" & lOutputRow) = wsSource.Range("E" & i)
Worksheets(sVillageCode).Range("D" & lOutputRow) = wsSource.Range("G" & i)
Worksheets(sVillageCode).Range("E" & lOutputRow) = wsSource.Range("H" & i)
Worksheets(sVillageCode).Range("F" & lOutputRow) = wsSource.Range("I" & i)
Worksheets(sVillageCode).Range("G" & lOutputRow) = wsSource.Range("K" & i)
Worksheets(sVillageCode).Range("H" & lOutputRow) = wsSource.Range("O" & i)
Worksheets(sVillageCode).Range("I" & lOutputRow) = wsSource.Range("P" & i)
Worksheets(sVillageCode).Range("J" & lOutputRow) = wsSource.Range("Q" & i)
Worksheets(sVillageCode).Range("K" & lOutputRow) = wsSource.Range("S" & i)
Worksheets(sVillageCode).Range("L" & lOutputRow) = wsSource.Range("R" & i)
Worksheets(sVillageCode).Range("M" & lOutputRow) = wsSource.Range("T" & i)

Next i

'Clean up the column sizes.
For Each ws In Worksheets
ws.Cells.EntireColumn.AutoFit
Next ws
Application.ScreenUpdating = True
End Sub

Private Sub CreateSheetWithHeaders(sWSName As String)
Dim wsNew As Worksheet
Set wsNew = Worksheets.Add
wsNew.Name = sWSName
wsNew.Range("A1") = "Surname"
wsNew.Range("B1") = "Name 1"
wsNew.Range("C1") = "Nick Name 1"
wsNew.Range("D1") = "Surname 2"
wsNew.Range("E1") = "Name 2"
wsNew.Range("F1") = "Nick Name 2"
wsNew.Range("G1") = "Address 1"
wsNew.Range("H1") = "Telephone"
wsNew.Range("I1") = "cell 1"
wsNew.Range("J1") = "cell 2"
wsNew.Range("K1") = "email 1"
wsNew.Range("L1") = "email 2"
wsNew.Range("M1") = "Village"
Set wsNew = Nothing
End Sub

Private Function WorksheetExists(sWSName As String) As Boolean
Dim ws As Worksheet
On Error GoTo NotThere
Set ws = Worksheets(sWSName)
Set ws = Nothing
WorksheetExists = True
Exit Function
NotThere:
WorksheetExists = False
End Function

 

[Fluff]

Deleted
Back in a mo

 

[Fluff]

Hi & welcome to the board
I can't see anything obviously wrong with your code & without your data it's not easy to diagnose.
Try this instead

Sub SplitSheet()
' saduff (ZZ2)

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

Application.ScreenUpdating = False

    Set SrcSht = Sheets("directory")
    Set Dict = CreateObject("scripting.dictionary")
    Set Trng = SrcSht.Range("T2", SrcSht.Range("T" & Rows.Count).End(xlUp))
    UsdRws = SrcSht.Cells.Find("*", after:=SrcSht.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Application.DisplayAlerts = False
    For Each Ws In Worksheets
        If LCase(Ws.Name) <> "directory" Then Ws.Delete
    Next Ws
Application.DisplayAlerts = True

    On Error Resume Next
    Trng.SpecialCells(xlBlanks).Value = "Unknown Village"
    On Error GoTo 0
    With Dict
        For Each Cl In Trng
            If Not .exists(Trim(UCase(Cl.Value))) Then .Add Trim(UCase(Cl.Value)), Nothing
        Next Cl
    End With
    
    For Each Ky In Dict
        Sheets.Add.Name = Ky
        With SrcSht
            .Range("A1").AutoFilter
            .Range("A1:T" & UsdRws).AutoFilter field:=20, Criteria1:=Ky
            .Range("A2:T" & UsdRws).SpecialCells(xlVisible).Copy Range("A2")
        End With
        Range("A:A,C:C,F:F,J:J, L:N").EntireColumn.Delete
        Range("A1") = "Surname"
        Range("B1") = "Name 1"
        Range("C1") = "Nick Name 1"
        Range("D1") = "Surname 2"
        Range("E1") = "Name 2"
        Range("F1") = "Nick Name 2"
        Range("G1") = "Address 1"
        Range("H1") = "Telephone"
        Range("I1") = "cell 1"
        Range("J1") = "cell 2"
        Range("K1") = "email 1"
        Range("L1") = "email 2"
        Range("M1") = "Village"
        Cells.EntireColumn.AutoFit
    Next Ky
    SrcSht.Range("A1").AutoFilter
        
End Sub

This replaces all your code, including the 2 functions