Problem Looping thru Worksheets

[zest1]

I have a few different subs that I incorprated into one and need to have it loop thru all the worksheets, but the code just repeats or attempts to run again on the first sheet until it errors out, never shifting to the next sheet.

I'm sure the problem is obvious, esp. to a more experienced eye. Can someone kindly take a look and see what the problem is. See attachment if needed...

Thanks a lot!

Sub ProjectFormatter()
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
'concatenate "Project" & "Cost" cells
    Dim cell As Range
    Dim sStart As String
    Dim rng As Range
 
    With Columns(1)
        Set cell = .Find("Project")
        If Not cell Is Nothing Then
            If cell.Row > 2 Then
                sStart = cell.Address
                Do
                    cell.Offset(0, 0).Value = cell.Offset(0, 0).Value & " - " & _
                    cell.Offset(1, 0).Value
                    If rng Is Nothing Then
                        Set rng = cell.Offset(1, 0)
                    Else
                        Set rng = Union(rng, cell.Offset(1, 0))
                    End If
                    Set cell = .FindNext(cell)
                Loop Until cell Is Nothing Or cell.Address = sStart
            End If
        End If
    End With
 
    If Not rng Is Nothing Then rng.EntireRow.Delete
'move "Project" cells up to same row as Phase (in col. D)
For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If Len(WorksheetFunction.Substitute(c, "Project", "")) <> Len(c) Then
        c.Cut c.Offset(-1, 2)
        c.Offset(1, 0).EntireRow.Delete
    End If
Next c
 
'------------------------------------------------------------
 
    Dim LastRow As Long
    Dim aCount As Long
    Dim iCount As Long
    Dim I As Long
 
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
 
    Range("A3").Select
    Do While ActiveCell.Row < LastRow
         '//Must be a value in col A
        If InStr(1, ActiveCell.Offset(0, 2), "Project") Then
             '//When project line move down to first task
            ActiveCell.Offset(1, 0).Select
            Do While InStr(1, ActiveCell.Offset(0, 2), "Project") = 0
                 '//move down task rows until next project found
                If ActiveCell.Row > LastRow Then
                     '//trap for when at end of dataset
                    Exit Do
                Else
                     '//actually move down and count rows moved
                    ActiveCell.Offset(1, 0).Select
                    aCount = aCount + 1
                End If
            Loop
             '//determine if any rows need inserting
            iCount = (10 - aCount)
            If iCount > 0 Then
                 '//don't insert when <= 0
                For I = 1 To iCount
                    ActiveCell.EntireRow.Insert
                    ActiveCell.Offset(1, 0).Select
                Next I
                 '//shift last row count by inserted rows amount
                LastRow = LastRow + iCount
            End If
             '//reset count
            aCount = 0
        End If
    Loop
Application.ScreenUpdating = True
Next ws
End Sub

[Norie]

You aren't actually referencing the worksheets you are looping through, so whenever you have something like this:
[vba]
Columns(1)[/vba] It will refer to the currently active sheet.

What you need is something like this.
[vba]
With ws.Columns(1)[/vba]

Also you don't need to select.

[Simon Lloyd]

Hi im by far an expert and i didnt test this until the code finished but it now moves on a sheet to perform the code again!

[vba]
Sub ProjectFormatter()
Application.ScreenUpdating = False
Dim ws As Worksheet
For ic = 1 To Sheets.Count ''''''''''Added This!
'For Each ws In Sheets
'concatenate "Project" & "Cost" cells
Dim cell As Range
Dim sStart As String
Dim rng As Range
Sheets(ic).Select ''''''Added This!
With Columns(1)
Set cell = .Find("Project")
If Not cell Is Nothing Then
If cell.Row > 2 Then
sStart = cell.Address
Do
cell.Offset(0, 0).Value = cell.Offset(0, 0).Value & " - " & _
cell.Offset(1, 0).Value
If rng Is Nothing Then
Set rng = cell.Offset(1, 0)
Else
Set rng = Union(rng, cell.Offset(1, 0))
End If
Set cell = .FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = sStart
End If
End If
End With

If Not rng Is Nothing Then
rng.EntireRow.Delete
End If
'move "Project" cells up to same row as Phase (in col. D)
For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Len(WorksheetFunction.Substitute(c, "Project", "")) <> Len(c) Then
c.Cut c.Offset(-1, 2)
c.Offset(1, 0).EntireRow.Delete
End If
Next c

'------------------------------------------------------------

Dim LastRow As Long
Dim aCount As Long
Dim iCount As Long
Dim I As Long

LastRow = Range("A" & Rows.Count).End(xlUp).Row

Range("A3").Select
Do While ActiveCell.Row < LastRow
'//Must be a value in col A
If InStr(1, ActiveCell.Offset(0, 2), "Project") Then
'//When project line move down to first task
ActiveCell.Offset(1, 0).Select
Do While InStr(1, ActiveCell.Offset(0, 2), "Project") = 0
'//move down task rows until next project found
If ActiveCell.Row > LastRow Then
'//trap for when at end of dataset
Exit Do
Else
'//actually move down and count rows moved
ActiveCell.Offset(1, 0).Select
aCount = aCount + 1
End If
Loop
'//determine if any rows need inserting
iCount = (10 - aCount)
If iCount > 0 Then
'//don't insert when <= 0
For I = 1 To iCount
ActiveCell.EntireRow.Insert
ActiveCell.Offset(1, 0).Select
Next I
'//shift last row count by inserted rows amount
LastRow = LastRow + iCount
End If
'//reset count
aCount = 0
End If
Loop
Application.ScreenUpdating = True
'Next ws
Next ic '''''Added this!
End Sub
[/vba]Regards,
Simon

[Simon Lloyd]

Add this line after [VBA]Next ic [/VBA]if you wish just to prove to yourself that it actually has completed all sheets [VBA]MsgBox "finished at sheet " & ic - 1[/VBA]Regards,
Simon

[Norie]

Simon

That might work but there really is no need to select anything.

In fact because of the use of ActiveCell later in the code it could actually cause problems.

I don't have the time right now but I'll download the OP's attachment and post back later with what I think the code should be.

[Simon Lloyd]

Norie, i'm ever happy to learn.....i just saw that his code wasnt actually being asked to move on a sheet so i thoufht it need to count sheets to move on, i do understand what you were saying about the With statement, its just because im still quite a novice compared to most of you i "couldn't see the woods for the trees!", i did think that in a with statement you can reference an object without slecting or activating it.

look forward to your post!

Regards,
Simon

[Norie]

Here's what I came up with.

The code runs and it definitely does something, but I don't know if it does what it's intended to do.
[vba]
Sub ProjectFormatter()
Dim ws As Worksheet
Dim c As Range
Dim sStart As String
Dim rng As Range
Dim LastRow As Long
Dim aCount As Long
Dim iCount As Long
Dim I As Long

Application.ScreenUpdating = False

For Each ws In ActiveWorkbook.Worksheets
Set rng = Nothing
With ws.Columns(1)
Set c = .Find("Project")
If Not c Is Nothing Then
If c.Row > 2 Then
sStart = c.Address
Do
c.Offset(0, 0).Value = c.Offset(0, 0).Value & " - " & c.Offset(1, 0).Value
If rng Is Nothing Then
Set rng = c.Offset(1, 0)
Else
Set rng = Union(rng, c.Offset(1, 0))
End If
Set c = .FindNext(c)
Loop Until c Is Nothing Or c.Address = sStart
End If
End If
End With

If Not rng Is Nothing Then rng.EntireRow.Delete

'move "Project" cells up to same row as Phase (in col. D)
For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Len(WorksheetFunction.Substitute(c, "Project", "")) <> Len(c) Then
c.Cut c.Offset(-1, 2)
c.Offset(1, 0).EntireRow.Delete
End If
Next c

LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row

Set rng = ws.Range("A3")
Do While rng.Row < LastRow
'//Must be a value in col A
If InStr(rng.Offset(0, 2), "Project") Then
'//When project line move down to first task
Set rng = rng.Offset(1, 0)
Do While InStr(rng.Offset(0, 2), "Project") = 0
'//move down task rows until next project found
If rng.Row > LastRow Then
'//trap for when at end of dataset
Exit Do
Else
'//actually move down and count rows moved
Set rng = rng.Offset(1, 0)
aCount = aCount + 1
End If
Loop
'//determine if any rows need inserting
iCount = (10 - aCount)
If iCount > 0 Then
'//don't insert when <= 0
For I = 1 To iCount
rng.EntireRow.Insert
Set rng = rng.Offset(1, 0)
Next I
'//shift last row count by inserted rows amount
LastRow = LastRow + iCount
End If
'//reset count
aCount = 0
End If
Set rng = rng.Offset(1)
Loop

Next ws
Application.ScreenUpdating = True
End Sub

[/vba]

[zest1]

Norie,
thanks for your help.

I ran the code, but it still does not progress to the subsequent sheets.

Also, the last section of the code now no longer works. It's supposed to add rows btwn the "Phases" entries on the sheet so that each Phase group has 10 rows.

[Norie]

The code I posted will loop through the sheets.

Like I said I don't know if the code does what it's intended to, because well I don't know what that is.

Perhaps if you explained that I could check it further.

[Norie]

Actually I think I found the problem.
[vba]
'move "Project" cells up to same row as Phase (in col. D)
For Each c In ws.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Len(WorksheetFunction.Substitute(c, "Project", "")) <> Len(c) Then
c.Cut c.Offset(-1, 2)
c.Offset(1, 0).EntireRow.Delete
End If
Next c[/vba]
The problem, again, was the missing reference to the worksheet.

I thought I'd spotted all of them but I missed that one.

But I'm still not 100% sure if the code will do what it's meant to.

[zest1]

Ok Norie.

I left the code in sections to make each section more evident in what it does, and to make it easier to troubleshoot in anticipation that any changes would affect the function of certain parts of it.

The worksheet has groups of entries, labeled "Phases" plus various data below. Each section of the code simply reformats the data in the following way:

The first section of the code concatenates all the "Cost" cells at the end of the "Project" cells (and adds " - " in between), and deletes those now empty rows where the "Cost" cells used to be.

The second section of the code then cuts the new (concatenated) "Project & Cost" cells and shifts them up 1 row and 2 columns over.

The third (last) section of the code checks to make sure that each "Phase" group contains 10 rows, and will add rows at the end of the "numbered" (ie. 1, 2, 3...) rows so that each group has 10 rows.

The entire code used to work fine before - and all I wanted was to have it move onto and run on the other sheets. But now there's a problem with the last section - it no longer add rows, but strangely adds a row in the wrong place - below "Phase 4" and below the "1" in that group.

Anyway, I tried running the code a few more times, but once again, it only runs on Sheet1, with no change to the other sheets (2 & 3). Btw, I have xl2k.

Hope this helps.
Thanks

[Norie]

Did you try the last piece of code I posted?

[zest1]

Norie,
I posted before I saw your last post.

Ok, made the correction you posted and the code now seems to run like it did before - it generates a "Runtime error 424 Object required" error on sheet1, and still does not transitioning to the other sheets.

edit - the macro errors here:
If Not rng Is Nothing Then rng.EntireRow.Delete

Thanks

[Simon Lloyd]

Zest you need to put an end if after that staement i saw that in your code and added one!

[VBA]If Not rng Is Nothing Then
rng.EntireRow.Delete
End If
[/VBA]

regards,
Simon

[zest1]

thanks Simon,

I had a suspicion about that. I made the change and the code now generates a "Runtime error 1004" here:

 
Set rng = Union(rng, cell.Offset(1, 0))

???

[Simon Lloyd]

yep i got that but in the code i posted when i saved the workbook opened it and ran it again it went through no problem.

Regards,
Simon

P.S just for tryings sake try the code i posted, its not as pretty as norie's but then im a novice - but it worked for me

[Simon Lloyd]

The problem is caused on sheets2 & 3 in the first cell where you have Company: ABC it has too many spaces if you take one space out on both sheets it works fine!
regards,
Simon

[zest1]

Ok Simon,

I inserted your code, and although the it now transitions to sheet2, it generates the same "Runtome error 1004" here:

 
Set rng = Union(rng, cell.Offset(1, 0))

Not sure what you're referring to about the spaces on sheets 2 & 3 - I searched those sheets for extra (double) spaces and found none.

Anyway, I think we're getting closer, thanks to both yours and Norie's help.

[Simon Lloyd]

At the top of each sheet you have Cell A1 which contains Company: ABC, there are 2 spaces here it needs to be one or if there is one space it needs to be one these only occur at the top of sheets 2 & 3 remove the spaces your code runs fine!

Regards,
Simon

[zest1]

Simon,
there are no extra spaces in A1 of sheets 2 & 3. Those pages are exact replicas (copy & paste) of sheet1. Besides I don't see why that would be an issue - nothing in the code checks for that.

I've tried repeatedly to get the code to run, but it just stops at that one point. It's got to be something really simple that we're overlooking.

Perhaps you could just attach the file, since you've got it working.

Thanks for your continued help on this.