More 2010 wierdness (1 Viewer)

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
I have a spreadsheet that I have set up as a Gantt chart with lots of little coloured squares and text boxes. One of my macros re-organises all of these based on start and finish dates of the individaul charts and fills in gaps where ones were deleted etc.

This all worked absolutley fine using 2007.

No more however.....

Since we were upgraded (downgraded...?) there is a particular wierdness happening that is really annoying me.

In the code is a line to insert some rows in a particular sheet and move the others down. Sometimes (and this is the bizzare part) but not always, when this part of the code runs, it moves the rows down but leaves the textboxes on that sheet where they were. This causes everything else to go awry and so I close without saving and start again.

What annoys me is that (a) it's happening in the first place and (b) sometimes it doesn't happen at all - even if nothing has changed since the last time I tried to do it and failed.

Anyone else have somethign similar and more importantly... a possible solution...?
 

noboffinme

Registered User.
Local time
Today, 10:03
Joined
Nov 28, 2007
Messages
288
Hi Darrell,

Have you tried stepping (F8) through the code to see what's happening with each line?

You should be able to find the line(s) that are making these changes.

Otherwise, I would need the file to see this for myself using both 2007 & 2010.

Hth
 

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
Yep, I know exactly which line it is. It is the insert rows line.
It used to insert them and move everything down when using 2007.

Now, it works sporadically, moving the rows down and leaving the textboxes where they were. Some days it's fine and other days it is useless.

There are 5 different sheets and sometimes it will work fine for 2-3 sheets and then stuff up the rest.

So..... so..... annoying......
 

noboffinme

Registered User.
Local time
Today, 10:03
Joined
Nov 28, 2007
Messages
288
I can only make assumptions & give general advice without access to the actual file.

It could be there are variables used in the code that are causing the inconsistencies, but I need the full code & preferably the file uploaded so I can try it out.
 

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
OK well here it is...

Code:
Sub Compress_Charts()
Dim ChartStart As Date
Dim PrevTxSt, TxSt, NextTxSt As Long
Dim PrevJobSt, JobSt, NextJobSt As Long
Dim PrevJobFin, JobFin, NextJobFin As Long
Dim LastRow, OrigRowNum, PlanCols As Long
Dim NewRowNum, PrevTBRowNum, TBRowNum As Long
Dim i, q, x, y, z, TotalRows As Long
Dim JobExist, SecOnRow As Boolean
Dim TB As Shape
Dim MyTBox, MyTBoxCom As String
Dim MySheet, NewSheet As Worksheet

On Error GoTo ErrHandler
Application.ScreenUpdating = False

' Save first incase something weird happens
ActiveWorkbook.Save
PlanCols = 224

' Create new sheet with headers
Set NewSheet = Sheets.Add
With NewSheet
    .Range("A1") = "TxColumn"
    .Range("B1") = "TestSt"
    .Range("C1") = "ShipDate"
    .Range("D1") = "RowNumJob"
    .Range("E1") = "TB Name"
    .Range("F1") = "TBCom Name"
    .Range("G1") = "RowNumTextBox"
    .Range("H1") = "NewRowJob"
    .Range("I1") = "NewRowTB"
End With

TotalRows = 276
' Cycle through each sheet
z = 1
Do Until z = ActiveWorkbook.Sheets.Count - 2
    y = 2
    Set MySheet = ActiveWorkbook.Sheets(z)
    With MySheet
        .Activate
        ChartStart = .Range("A3").Value
        x = 6
        Do Until x > TotalRows
            JobExist = False
            ' Does row have a job on it
            .Range("A" & x).Select
            For i = 1 To PlanCols
                If ActiveCell.Interior.Color = 16777215 Or ActiveCell.Interior.Color = RGB(217, 217, 217) Or ActiveCell.Interior.Color = RGB(242, 242, 242) Then
                    ActiveCell.Offset(0, 1).Select
                Else
                    JobExist = True
                    Exit For
                End If
            Next i
        
            If JobExist = True Then
                'Find Transformer
                TxSt = 0
                .Range("A" & x).Select
                For i = 1 To PlanCols
                    If InStr(1, LCase(ActiveCell.Value), "s") > 0 Or InStr(1, LCase(ActiveCell.Value), "x") > 0 Then
                        TxSt = ActiveCell.Column
                        Exit For
                    Else
                        ActiveCell.Offset(0, 1).Select
                    End If
                Next i
                'Find Start column
                .Range("A" & x).Select
                For i = 1 To PlanCols
                    If ActiveCell.Interior.Color = 16777215 Or ActiveCell.Interior.Color = RGB(217, 217, 217) Or ActiveCell.Interior.Color = RGB(242, 242, 242) Then
                        ActiveCell.Offset(0, 1).Select
                    Else
                        JobSt = ActiveCell.Column
                        Exit For
                    End If
                Next i
                'Find Finish column
                .Cells(x, PlanCols).Select
                For i = PlanCols To 1 Step -1
                    If ActiveCell.Interior.Color = 16777215 Or ActiveCell.Interior.Color = RGB(217, 217, 217) Or ActiveCell.Interior.Color = RGB(242, 242, 242) Then
                        ActiveCell.Offset(0, -1).Select
                    Else
                        JobFin = ActiveCell.Column
                        Exit For
                    End If
                Next i
        
                NewSheet.Activate
                With NewSheet
                    If Not MySheet.Name = "Transformers" Then
                        If TxSt > JobSt Then
                            TxSt = 0
                        End If
                    End If
                    .Range("A" & y).Value = TxSt
                    .Range("B" & y).Value = JobSt
                    .Range("C" & y).Value = JobFin
                    .Range("D" & y).Value = x
                End With
                y = y + 1
                MySheet.Activate
            End If
            x = x + 2
        Loop

        ' Ensure row hieghts, column widths are correct
        .Cells.RowHeight = 11.25
        .Cells.ColumnWidth = 1.71
        .Rows("1:1").RowHeight = 15
        .Range("A1").Select
        y = 2
        ' Look for main textboxes
        For Each TB In ActiveSheet.Shapes
            If TB.Fill.ForeColor.RGB = RGB(255, 255, 0) Then
                NewSheet.Activate
                With NewSheet
                    .Range("E" & y).Value = TB.Name
                    .Range("G" & y).Value = ((TB.Top - 15) / 11.25) + 3
                End With
            Else
                ' This is a comment textbox.  Find other textbox data and add to correct cell.
                NewSheet.Activate
                With NewSheet
                    TBRowNum = ((TB.Top - 15) / 11.25) + 3
                    For q = 2 To .UsedRange.Rows.Count
                        If TBRowNum = .Range("F" & q).Value Then
                            .Range("F" & q).Value = TB.Name
                            Exit For
                        End If
                    Next q
                End With
                y = y - 1
            End If
            y = y + 1
        Next TB
        
        NewSheet.Activate
        With NewSheet
            x = 6
            LastRow = .Range("A65536").End(xlUp).Row
            .Columns("E:G").Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlYes
            For i = 2 To LastRow
                .Range("H" & i).Value = x
                x = x + 2
            Next i
            x = 5
            For i = 2 To LastRow
                .Range("I" & i).Value = x
                If i = LastRow Then
                    Exit For
                End If
                .Range("I" & i + 1).Value = x + 1
                x = x + 4
                i = i + 1
            Next i
            If MySheet.Name = "Transformers" Then
                .Columns("A:G").Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:=xlYes
            Else
                .Columns("A:G").Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2"), Order2:=xlAscending, Header:=xlYes
            End If
        End With
    
        'Copy last rows and delete any jobs if on these rows
        MySheet.Activate
        .Rows(TotalRows - 23 & ":" & TotalRows).Copy
        .Rows("5:5").Insert Shift:=xlDown                         <<=========
        .Rows("5:12").ClearContents
        x = 6
        Do Until x = 30
            .Range("A" & x).Select
            For i = 1 To PlanCols
                If ActiveCell.Interior.Color = 16777215 Or ActiveCell.Interior.Color = RGB(217, 217, 217) Or ActiveCell.Interior.Color = RGB(242, 242, 242) Then
                    ActiveCell.Offset(0, 1).Select
                Else
                    ActiveCell.Interior.ColorIndex = xlNone
                    ActiveCell.Offset(0, 1).Select
                End If
            Next i
            x = x + 2
        Loop
        For Each TB In ActiveSheet.Shapes
            TBRowNum = ((TB.Top - 15) / 11.25) + 3
            If TBRowNum < 23 Then
                TB.Delete
            End If
        Next TB
        
        NewSheet.Activate
        With NewSheet
            For i = 2 To LastRow
                .Range("D" & i).Value = .Range("D" & i).Value + 24
                .Range("G" & i).Value = .Range("G" & i).Value + 24
            Next i
            
            For i = 2 To LastRow
                SecOnRow = False
                TxSt = .Range("A" & i).Value
                PrevTxSt = .Range("A" & i - 1).Value
                NextTxSt = .Range("A" & i + 1).Value
                JobSt = .Range("B" & i).Value
                PrevJobSt = .Range("B" & i - 1).Value
                NextJobSt = .Range("B" & i + 1).Value
                JobFin = .Range("C" & i).Value
                PrevJobFin = .Range("C" & i - 1).Value
                NextJobFin = .Range("C" & i + 1).Value
                OrigRowNum = .Range("D" & i).Value
                MyTBox = .Range("E" & i).Value
                MyTBoxCom = .Range("F" & i).Value
                NewRowNum = .Range("H" & i).Value
                TBRowNum = .Range("I" & i).Value
                PrevTBRowNum = .Range("I" & i - 1).Value
            
                If TBRowNum - 1 = PrevTBRowNum Then
                    SecOnRow = True
                End If
                   
                MySheet.Activate
                With MySheet
                    ' If job is on same place don't move
                    If Not OrigRowNum = NewRowNum Then
                        If Not TxSt = 0 Then
                            If MySheet.Name = "Transformers" Then
                                If PrevJobSt < PrevTxSt Then
                                    PrevTxSt = PrevJobSt
                                End If
                                If JobSt < TxSt Then
                                    TxSt = JobSt
                                End If
                                If NextJobSt < NextTxSt Then
                                    NextTxSt = NextJobSt
                                End If
                            End If
                            .Range(Cells(OrigRowNum, TxSt), Cells(OrigRowNum, JobFin)).Copy
                            .Cells(NewRowNum, TxSt).Select
                            ActiveSheet.Paste
                            .Range(Cells(TotalRows + 23, TxSt), Cells(TotalRows + 23, JobFin)).Copy
                            .Cells(OrigRowNum, TxSt).Select
                            ActiveSheet.Paste
                        Else
                            .Range(Cells(OrigRowNum, JobSt), Cells(OrigRowNum, JobFin)).Copy
                            .Cells(NewRowNum, JobSt).Select
                            ActiveSheet.Paste
                            .Range(Cells(TotalRows + 23, JobSt), Cells(TotalRows + 23, JobFin)).Copy
                            .Cells(OrigRowNum, JobSt).Select
                            ActiveSheet.Paste
                        End If
                        For Each TB In ActiveSheet.Shapes
                            If TB.Name = MyTBox Then
                                TB.Cut
                                If JobSt < 21 Then
                                    If SecOnRow = True Then
                                        If JobFin < PrevJobFin Then
                                            .Cells(TBRowNum, PrevJobFin + 11).Select
                                        Else
                                            .Cells(TBRowNum, JobFin + 11).Select
                                        End If
                                    Else
                                        If JobFin > NextJobFin Then
                                            .Cells(TBRowNum, JobFin + 2).Select
                                        Else
                                            .Cells(TBRowNum, NextJobFin + 2).Select
                                        End If
                                    End If
                                    ActiveSheet.Paste
                                    Exit For
                                Else
                                    If SecOnRow = True Then
                                        If Not TxSt = 0 Then
                                            If Not PrevTxSt = 0 Then
                                                If PrevTxSt < TxSt Then
                                                    PrevJobSt = PrevTxSt
                                                Else
                                                    PrevJobSt = TxSt
                                                End If
                                            Else
                                                If PrevJobSt > TxSt Then
                                                    PrevJobSt = TxSt
                                                End If
                                            End If
                                        Else
                                            If Not PrevTxSt = 0 Then
                                                PrevJobSt = PrevTxSt
                                            End If
                                        End If
                                        If PrevJobSt < 21 Then
                                            If JobFin < PrevJobFin Then
                                                .Cells(TBRowNum, PrevJobFin + 11).Select
                                            Else
                                                .Cells(TBRowNum, JobFin + 11).Select
                                            End If
                                        Else
                                            .Cells(TBRowNum, PrevJobSt - 9).Select
                                        End If
                                    Else
                                        If Not TxSt = 0 Then
                                            JobSt = TxSt
                                        End If
                                        If Not NextTxSt = 0 Then
                                            If NextTxSt < JobSt Then
                                                JobSt = NextTxSt
                                            End If
                                        End If
                                        If JobSt < 21 Then
                                            If JobFin > NextJobFin Then
                                                .Cells(TBRowNum, JobFin + 2).Select
                                            Else
                                                .Cells(TBRowNum, NextJobFin + 2).Select
                                            End If
                                        Else
                                            .Cells(TBRowNum, JobSt - 18).Select
                                        End If
                                    End If
                                    ActiveSheet.Paste
                                    Exit For
                                End If
                            End If
                        Next TB
                    End If
                    For Each TB In ActiveSheet.Shapes
                        If TB.Name = MyTBoxCom Then
                            TB.Cut
                            .Cells(TBRowNum, NextJobFin + 2).Select
                            ActiveSheet.Paste
                            Exit For
                        End If
                    Next TB
                End With
            Next i
        End With
        .Rows(TotalRows + 1 & ":" & TotalRows + 24).Delete Shift:=xlUp
        .Range("A1").Select
    End With
    NewSheet.Activate
    With NewSheet
        .Range("A2:I" & .UsedRange.Rows.Count).ClearContents
    End With
    z = z + 1
Loop
    
Application.DisplayAlerts = False
NewSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Plans re-sorted and compressed", vbInformation, "Update Plan Sequence"

Exit_Sub:
    Set NewSheet = Nothing
    Set MySheet = Nothing
    Exit Sub
    
ErrHandler:
     MsgBox Err.Source & ", " & Err.Description, vbOKOnly
     GoTo Exit_Sub
End Sub

On the 'Controls' tab of this spreadsheet are the buttons for this and other functions.
Good luck.....
 

Attachments

  • Gantt Charts.xls
    1.5 MB · Views: 129
Last edited:

noboffinme

Registered User.
Local time
Today, 10:03
Joined
Nov 28, 2007
Messages
288
Hi Darrell,

So the yellow Text boxes are supposed to move based on the code in the 'Compress Charts' Sub which runs from the 'Re-Organise All Gantt Charts' button.

Which line(s) select the text boxes & moves them?
 

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
Hi

Before anything is actually re-arranged, I insert 24 blank rows at the start to give me some space to copy job details into.

This is done by

Code:
.Rows(TotalRows - 23 & ":" & TotalRows).Copy
.Rows("5:5").Insert Shift:=xlDown                  <---- Here's where it goes bad...

and as stated - using 2007, this always moved the existing rows AND their associated textboxes down by 24 rows.

Then the details gathered earlier in the code are used to move one order line at a time - starting at the top - and it's textbox into it's new position.

Hope this helps...
 

noboffinme

Registered User.
Local time
Today, 10:03
Joined
Nov 28, 2007
Messages
288
OK, so where does this code reside in relation to the 'Compress Charts' code?
 

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
It's about halfway down....

Sorry - I don't know a better way of highlighting it
 

noboffinme

Registered User.
Local time
Today, 10:03
Joined
Nov 28, 2007
Messages
288
OK, I've sort of got it working so that I can run the code & check the error.

Is it supposed to add the Rows to the UPS-I Worksheet or a blank Worksheet?
 

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
It cycles through every sheet and will add rows to each one except for the last two.

The new sheet that gets created is just a place to re-sort the data and be used as a reference for putting the charts back in the correct order.
 

noboffinme

Registered User.
Local time
Today, 10:03
Joined
Nov 28, 2007
Messages
288
Sorry Darrell,

I've run this in 2007, 2010 & 2013 & I can't replicate the error.
 

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
Well thanks for trying... It's working for me this week as well.

This is half the problem though - If it stuffed up ALL the time it would be easier to fix.
 

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
OK well as a workaround - I've had to include some code that checks if the textboxes moved properly or not and if they didn't then to move them one at a time to where they should've moved to. Of course another snag to this is that by cutting and pasting them in this way, Excel gives them a new name and so I then have to update the list I generated the new names also.
Very crude but mostly effective....
 

lemo

Registered User.
Local time
Yesterday, 20:03
Joined
Apr 30, 2008
Messages
187
could it be that in 2007 the function looks like .Insert Shift:=xlDown and in 2010 it looks like .Insert Shift:=xlShiftDown ?l
 

Darrell

Registered User.
Local time
Today, 00:03
Joined
Feb 1, 2001
Messages
299
Hi Lemo, I can confirm that made no difference at all.

Thanks anyway
 

Users who are viewing this thread

Top Bottom