Create new sheets fro multiple tabs

Microsoft Excel 2007
February 20, 2010 at 06:04:20
Specs: Windows XP
Hello,

I am new to VBA and I need help writing a
macros to create many new worksheets from
rows of data contained in a workbook that has
several tabs. My data is from multiple climate
stations (each sheet (or tab) contains data
from one station), and I need to create
individual new worksheets by date with data
from multiple stations. I tried
using the macro recorder, but the scripts are
so large that I need several modules to
complete the work. My data looks like this:

Date Value1 Value2 Value3 Lat Long
Jan80 123 155 50 444 555
Feb80 156 547 952 444 555

This is the type of data on a worksheet named
"Site1" and the format is repeated for each of
45 sites in a workbook. What I need are
individual worksheets named "Jan80Value1"
with the Value1, Lat, and Long data from that
row from each Site tab in the workbook.
Repeat this for each date in column 1 and for
each Value. In the end I will have over 1000
new worksheets (saved as individual files)
named "Jan80Value1", "Jan80Value2",
"Jan80Value3", "Feb80Value1".....

Can anyone help me write a script to loop or
iterate through the steps?

Thanks.


See More: Create new sheets fro multiple tabs

Report •


#1
February 20, 2010 at 08:27:28
Hi,

This is quite a complex task.

First you need to go through multiple worksheets and find all the dates.
For each date create a new worksheet named with that date plus the data that follows it (Value 1), unless a worksheet with that name exists,
then
Go through all the worksheets again, and copy the data to the worksheet with that row's date + value 1 as its name.

This macro assumes that all worksheets with site data start with "Site", e.g. "Site1"
Worksheets that do not start with "Site" are ignored.

As changes made by macros cannot be undone ensure that you test this macro on a copy of your data. Always make a copy of your data before running the macro on your actual data.

Option Explicit

Private Sub DateTabs()
Dim wsEach As Worksheet
Dim rngEnd As Range
Dim rngCell As Range
Dim strWsName As String
Dim rngDestEnd As Range

On Error GoTo ErrHnd

With ActiveWorkbook
    'create worksheet names
    'loop through all worksheets
    For Each wsEach In .Worksheets()
        'only look in worksheets named "Site ..."
        If Left(wsEach.Name, 4) = "Site" Then
            'find end of data in column A
            Set rngEnd = wsEach.Range("A" & CStr(wsEach.Rows.Count)).End(xlUp)
            'loop through cells in used range (column A)
            For Each rngCell In wsEach.Range("A2", rngEnd)
                'create a worksheet name from text in columns A & B
                strWsName = rngCell.Text & rngCell.Offset(0, 1).Text
                    'test if worksheet exists
                    On Error Resume Next
                    If .Worksheets(strWsName) Is Nothing Then
                        On Error GoTo ErrHnd
                        'create new sheet
                        .Worksheets.Add After:=.Worksheets(Worksheets.Count)
                        'name new sheet
                        .Worksheets(Worksheets.Count).Name = strWsName
                        'copy header row
                        wsEach.Range("A1:F1").Copy _
                            Destination:=.Worksheets(strWsName).Range("A1")
                    End If
                    On Error GoTo ErrHnd
            Next rngCell
        End If
    Next wsEach
    
    'copy data to appropriate worksheets
    'loop through all worksheets
    For Each wsEach In .Worksheets()
        'only look in worksheets named "Site ..."
        If Left(wsEach.Name, 4) = "Site" Then
            'find end of data in column A
            Set rngEnd = wsEach.Range("A" & CStr(wsEach.Rows.Count)).End(xlUp)
            'loop through cells in used range (column A)
            For Each rngCell In wsEach.Range("A2", rngEnd)
                'create a worksheet name from text in columns A & B
                strWsName = rngCell.Text & rngCell.Offset(0, 1).Text
                'find end of data in destination worksheet + 1 row
                Set rngDestEnd = .Worksheets(strWsName). _
                        Range("A" & CStr(.Worksheets(strWsName).Rows.Count)) _
                        .End(xlUp).Offset(1, 0)
                'copy cells to destination
                rngCell.Resize(1, 6).Copy Destination:=rngDestEnd
            Next rngCell
        End If
    Next wsEach
End With
Exit Sub
'error handler
ErrHnd:
Err.Clear
End Sub

Note that some lines of code are split onto 2 or more lines using the line continuation character _
This should work OK when copied and pasted.

As you have worked with macros before, I have not included a description of how to create the macro code in the VBA window, but if you have problems, please ask.

As I do not have your actual data I cannot be sure that this macro will do exactly what you want. I have included comments in the code to make it easier to make changes yourself, or ask for more assistance.

Regards


Report •
Related Solutions


Ask Question