Trying to generate mutiple list for one

  • Thread starter Thread starter ROn
  • Start date Start date
R

ROn

This is a repeat question. Im want to be able to make a
list of names. In the spreadsheet i want to list
Name/DOB/City. Is there anyway to automate(macro?) the
list to organize themselves into seperate worksheets
based upon the city the names are in?

I just dont want to have to search thru names and do alot
of cut and pasting to seperate them

Thank You all
 
Try this:

Sub moveToCitySheet()

Dim startSheet As Worksheet
Dim mySheet As Worksheet
Dim columnCity As Integer
Dim lastDataColumn As Integer
Dim firstRowOfData As Integer
Dim i As Integer
Dim j As Integer
Dim sheetExists As Boolean
Dim alreadyHeardThis As Boolean
Dim currentRow As Integer
Set startSheet = ActiveSheet
columnCity = 3 'change if you want another column to create sheets
lastDataColumn = 3 'change if you want more than 3 columns of data
firstRowOfData = 2
i = firstRowOfData 'first row with data
'delete any existing sheet with city name, i.e. last run
alreadyHeardThis = False
While startSheet.Cells(i, 1) <> "" 'Loop until row (i) column 1 is blank
For Each mySheet In ActiveWorkbook.Sheets
If CStr(startSheet.Cells(i, columnCity).Value) = mySheet.Name
Then
If startSheet.Name = mySheet.Name Then
If Not alreadyHeardThis Then MsgBox "Can't Delete the
start sheet and will not populate it"
alreadyHeardThis = True
Exit For
Else
Application.DisplayAlerts = False
mySheet.Delete
Application.DisplayAlerts = True
Exit For
End If
End If
Next
i = i + 1
Wend
i = firstRowOfData
'Now create sheets
While startSheet.Cells(i, 1) <> ""
sheetExists = False
For Each mySheet In ActiveWorkbook.Sheets 'check to see if already
created
If CStr(startSheet.Cells(i, columnCity).Value) = mySheet.Name
Then
sheetExists = True
Exit For
End If
Next
If Not sheetExists Then
Sheets.Add.Name = CStr(startSheet.Cells(i, columnCity).Value)
For j = 1 To lastDataColumn 'Add Headers
Cells(1, j) = startSheet.Cells(1, j)
Cells(2, 1).Select 'get it ready to populate
Next
End If
i = i + 1
Wend
'Now populate the sheets
i = firstRowOfData
While startSheet.Cells(i, 1) <> ""
If Not startSheet.Name = CStr(startSheet.Cells(i,
columnCity).Value) Then
Sheets(CStr(startSheet.Cells(i, columnCity).Value)).Select
currentRow = ActiveCell.Row
For j = 1 To lastDataColumn 'Add Headers
Cells(currentRow, j) = startSheet.Cells(i, j)
Cells(currentRow, j).NumberFormat = startSheet.Cells(i,
j).NumberFormat
Cells(currentRow + 1, 1).Select 'get it ready to
populate next
Next
End If
i = i + 1
Wend

End Sub
 
Back
Top