Loop and append to different worksheets

Thread view:

Enable EMail Alerts

Start New Thread

Thread rating:

Dow - 14 Mar 2008 13:42 GMT

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

Reply to this Message

Joel - 14 Mar 2008 15:00 GMT

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

> I posted this previously but I have discovered a few more things about
> it and still need some help.
[quoted text clipped - 67 lines]
>
> End Sub

Reply to this Message

Dow - 14 Mar 2008 19:07 GMT

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.

> 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
[quoted text clipped - 121 lines]
>
> - Show quoted text -

Reply to this Message

Joel - 14 Mar 2008 20:23 GMT

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)

> Thank you for the response. I popped this code into my excel and got
> an error at this point:
[quoted text clipped - 132 lines]
> >
> > - Show quoted text -

Reply to this Message

Dow - 18 Mar 2008 17:42 GMT

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?

> I just copied your original code. Why not make you code a lot simplier with
> this code below
[quoted text clipped - 144 lines]
>
> - Show quoted text -

Reply to this Message

Dow - 18 Mar 2008 17:43 GMT

> 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
[quoted text clipped - 150 lines]
>
> - 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.

Reply to this Message