View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Dow Dow is offline
external usenet poster
 
Posts: 31
Default Loop and append to different worksheets

I posted this previously but I have discovered a few more things about
it and still need some help.

I need help making this macro loop through more than one worksheet.
And I need to make sure that the information appends correctly. Or I
need a different Macro that will do that. I have looked at
http://www.contextures.com/excelfiles.html and unfortunately the
macros there did not quite do what I need.

I have anywhere from one to 16 different worksheets with no duplicate
information. It is all in the same format, the worksheet names will
differ from month to month.

What I need to do is create new worksheets based on the information
from a column. Column K could have anywhere from 1 to 6 different
values A, B, C, D, E, or F. I need a seperate worksheet with all the
rows containing the A's, all the B's, etc.

This macro works great on one worksheet. I have tried a few things to
make it work on more than one but I have had no luck and I know there
are a lot of people here with much more experiance than I have. Thank
you for any help you can provide.

From a post by Bernie Deitrick:
Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column
Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer


myShtName = ActiveSheet.Name
KeyCol = InputBox("What column # within database to use as key?")


Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(0,
0).Cells


Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)


For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(befo=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=myCell.Value
.SpecialCells(xlCellTypeVisible).Copy _
mySht.Range("A1")
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
End With
Resume
SheetExists:
Next myCell


'Optional section to export the sheets to separate files
'For Each mySht In ActiveWorkbook.Worksheets
'If mySht.Name = myShtName Then
'Exit Sub
'Else
'mySht.Move
'ActiveWorkbook.SaveAs "Workbook " & ActiveSheet.Name & ".xls"
'ActiveWorkbook.Close
'End If
'Next mySht


End Sub