Try this on a COPY of your workbook.
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("F" & 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("C" & 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("I" & i)
Worksheets(sVillageCode).Range("E" & lOutputRow) = wsSource.Range("J" & i)
Worksheets(sVillageCode).Range("F" & lOutputRow) = wsSource.Range("F" & i)
Worksheets(sVillageCode).Range("G" & lOutputRow) = wsSource.Range("V" & i)
Worksheets(sVillageCode).Range("H" & lOutputRow) = wsSource.Range("W" & 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") = "title"
wsNew.Range("C1") = "Address2"
wsNew.Range("D1") = "telephone"
wsNew.Range("E1") = "phone/fax"
wsNew.Range("F1") = "village"
wsNew.Range("G1") = "email1"
wsNew.Range("H1") = "email2"
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
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks