```
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
```