Loop and append to different worksheets

[Dow]

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(before:=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

 

[Joel]

The code gets all the sheet names at the beginning. Then loop through this
list of names. The way when you add a new sheet the code doesn't look at the
new sheets only the old sheets.


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
Dim sheetnames() As Variant
ReDim sheetnames(Sheets.Count)
Index = 0
For Each sht In ThisWorkbook.Sheets
sheetnames(Index) = sht.Name
Index = Index + 1
Next sht

For Each sht In sheetnames

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


Set myArea = sht.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(before:=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

Next sht

End Sub

 

[Dow]

Thank you for the response. I popped this code into my excel and got
an error at this point:

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

Unfortunately I will not have time to play around with it until next
week. I do hope to continue working on it then.

Thank you again.

 

[Joel]

I just copied your original code. Why not make you code a lot simplier with
this code below

from
Set myArea = sht.ActiveCell.CurrentRegion. _
Columns(KeyCol).Offset(0, 0)
Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)
to
set myarea = sht.columns(keycol)

 

[Dow]

I start with 2 or 3 workbooks. This code still works on only the
first one. How can we make it loop through the second workbook and
add the data to the newly created worksheets?

 

[Dow]

I start with 2 or 3 workbooks.  This code still works on only the
first one.  How can we make it loop through the second workbook and
add the data to the newly created worksheets?






- Show quoted text -

Let me correct what I wrote above. I start with 2 or 3 worksheets.
And I would like to loop through the worksheets. They are all in the
same workbook.