Insert sheets and copy

[Zaichik123]

Hi,

I have a report that I need to split down into several sheets within the same workbook. I've already developed the majority of the code, but am struggling to add the correct number of sheets and then copy info into the 'next sheet'??

Dim strDept As String
Dim strGrp As String
Dim strRmNum As String
Dim strRmName As String

Dim strPrevDept As String
Dim strPrevGrp As String
Dim strPrevRmNum As String
Dim strPrevRmName As String
Dim Row As Long
Dim BlankRow As Long

Do
Row = Row + 1
Range("A" & Row).Select
' locate beginning of data
If ActiveCell.FormulaR1C1 = "Dept" Then Exit Do
Loop

Do
DoEvents
Row = Row + 1
Range("A" & Row).Select
strDept = LCase$(ActiveCell.FormulaR1C1)
Range("B" & Row).Select
strGrp = LCase$(ActiveCell.FormulaR1C1)
Range("C" & Row).Select
strRmNum = LCase$(ActiveCell.FormulaR1C1)
Range("D" & Row).Select
strRmName = LCase$(ActiveCell.FormulaR1C1)
Range("E" & Row).Select
strRmName = LCase$(ActiveCell.FormulaR1C1)

If strDept = "" And strGrp = "" And strRmNum = ""

(here's where I'm having trouble...)

Then
Sheets("Equipment_by_Room").Select
Sheets.Add
' if have found more than 10 consequtive blank rows then have completed all data
If BlankRow = 10 Then Exit Do
Else
BlankRow = 0
End If

If strDept = strPrevDept _
And strGrp = strPrevGrp _
And strRmNum = strPrevRmNum _
And strRmName = strPrevRmName Then ' this row has the same details as the row before

(here's where I'm having trouble...)

Range("A" & Row, "Z" & Row).Select
Selection.Copy
ActiveSheet.Paste
Else ' commencing rows for the next room
strPrevDept = strDept
strPrevGrp = strGrp
strPrevRmNum = strRmNum
strPrevRmName = strRmName
End If

Please help!

 

[SkipVought]

Zaichik123,

I have to ask the question: Why are you spltting up data in your workbook? THis is generally not a good idea. What is the business case for doing this?

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884

 

[Zaichik123]

I agree, but the report is for several different rooms within a department that need to be on different sheets within the same xls file.

'Split' I suppose isn't the correct term - separate seems more suitable.

 

[SkipVought]

Why not use the Sort, Autofilter, PivotTable, Subtotal etc features to report based on department. The have the user enter the department before displaying any data. Then the see whatever they need to see -- ALL ON A SINGLE SHEET?

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884

 

[Zaichik123]

Trust me I would love to, but unfortunately this is on a massive scale and the report is for several external users whom aren't particularly IT savvy.

 

[SkipVought]

If they can click on a sheet tab, you can format a report for them FROM A SINGLE SHEET.

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884

 

[Zaichik123]

The formatting of the report is not the issue, I need the macro to recognise the next room instance, add a sheet, copy that rooms data into that sheet and then continue doing so through the rest of the report.

Hope this clarifies...

 

[SkipVought]

That does not change anything. I'm not suggesting that all the reporting necessarily needs to be on the sheet containing the source data -- could be, but does not need to be. So data comes from 2 or more sources and is reported on a separate sheet. It's still based on the context of the user and reported on a single sheet.

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884

 

[Zaichik123]

The report is for several rooms within a department, the macro is to count how many rooms, add that amount of sheets, and each time it adds a sheet it should copy the room info into that sheet.

 

[SkipVought]

Wow! This sounds like a disaster!

Sub test()
    With Sheets("First QT").Range("B1:B2034")
        Set rngGMPCA = .Find(rngDAFRPCA, LookIn:=xlValues)
        'Moves to next GM PCA and test for match.
        Set rngToCopy = rngToCopy.Offset(1, 0)
               
        If rngGMPCA Is Nothing Then
            'Records comment in cell with DAFR PCA to alert user
        '    to non-matching problem all the DAFRPCAs have been tested
             rngDestin = "No data retreived."
             strEscape = rngDAFRPCA.Value
                        
            Do Until strEscape <> rngDAFRPCA.Value
                                          
               'Moves to next GM PCA and test for match.
               Set rngDAFRPCA = rngDAFRPCA.Offset(1, 0)
               Set rngDestin = rngDestin.Offset(1, 0)
               rngDestin = "No data retreived."
            Loop
                           
            With Sheets("First QT").Range("B1:B2034")
                Set rngGMPCA = .Find(rngDAFRPCA, LookIn:=xlValues)
                           
                If rngGMPCA Is Nothing Then
                   'Set rngGMPCA =
                End If
                                                     
                Set rngToCopy = rngToCopy.Offset(1, 0)
                Set rngDestin = rngDestin.Offset(1, 0)
                           
            End With
        End If
    End With

End Sub
Sub nn()
    Dim strDept As String
Dim strGrp As String
Dim strRmNum As String
Dim strRmName As String

Dim strPrevDept As String
Dim strPrevGrp As String
Dim strPrevRmNum As String
Dim strPrevRmName As String
Dim Row As Long
Dim BlankRow As Long

    Dim wsThis As Worksheet, wsNew As Worksheet
    
    Set wsThis = ActiveSheet
    
    With wsThis.UsedRange
        r1 = .Row
        r2 = r1 + .Rows.Count - 1
    End With
    Row = r1
    Do
        DoEvents
        Row = Row + 1
        strDept = LCase$(wsThis.Range("A" & Row).Value)
        strGrp = LCase$(wsThis.Range("B" & Row).Value)
        strRmNum = LCase$(wsThis.Range("C" & Row).Value)
        strRmName = LCase$(wsThis.Range("D" & Row).Value)
        strRmName = LCase$(wsThis.Range("E" & Row).Value)
        
        If strDept = "" And strGrp = "" And strRmNum = "" Then

'            Sheets("Equipment_by_Room").Select
            Set wsNew = Sheets.Add
            ' if have found more than 10 consequtive blank rows then have completed all data
            If BlankRow = 10 Then Exit Do
        Else
            BlankRow = 0
        End If
        
        If strDept = strPrevDept _
            And strGrp = strPrevGrp _
            And strRmNum = strPrevRmNum _
            And strRmName = strPrevRmName Then  ' this row has the same details as the row before


            wsThis.Range("A" & Row, "Z" & Row).Copy Destination:=wsNew.[A1]
        Else ' commencing rows for the next room
            strPrevDept = strDept
            strPrevGrp = strGrp
            strPrevRmNum = strRmNum
            strPrevRmName = strRmName
        End If
End Sub

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884

 

[Zaichik123]

Thanks Skip but it needs a bit of debugging...

nn - First it asked me to Do without Loop so I added in a loop at the end of the code but the macro had no control over the amount of sheets added and didn't copy the text.

test - tells me Subject out of Range, or Object Required if I change the filename/location.

Any suggestions?

 

[SkipVought]

1) I'm sorry that I picked up another block of code, test, that has nothing to do with your opportunity.

2) You original code had no ending Loop to go along with the Do.

3) this code copies and pastes from the original sheet to the new sheet A1.

wsThis.Range("A" & Row, "Z" & Row).Copy Destination:=wsNew.[A1]

4) I can't tell if the test will work.

If BlankRow = 10 Then Exit Do

It depends on your data.

I'd suggest that you step thru the code and observe the values that are being used to control the flow.

Skip,

Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884

 

[Zaichik123]

My fault to be honest, I should have scrutinised the code more myself to realise that - but to be honest didn't have time...

Thanks for your help

 

[KenWright]

Or you could just dump the lot into a Pivot Table, drag the dept into the page fields, get the report the way you want it, and then use the ShowPages Option on the PivotTable Toolbar.

Regards
Ken....................

----------------------------------------------------------------------------
It's easier to beg forgiveness than ask permission

----------------------------------------------------------------------------