JC_Lives
asked on
Excel VBA - Page setup stalls my macro
Hi, I am trying to run the attached code but the page setup window stalls my macro and I have to close it before the macro continues executing!!l Pease fix my problem!!!
Sub MarkettasMacro()
'
' MarkettasMacro Macro
' Macro recorded 4/21/2009 by Luke Baer
'
'
Application.ScreenUpdating = False
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("M:M").Select
Selection.Delete Shift:=xlToLeft
Cells.Select
Range("H1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.SelectedSheets.PrintPreview
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = True
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 73
.PrintErrors = xlPrintErrorsDisplayed
End With
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = True
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 73
.PrintErrors = xlPrintErrorsDisplayed
End With
Range("B1").Select
Columns("A:A").ColumnWidth = 6.71
Columns("A:A").ColumnWidth = 7
Range("B7").Select
Columns("F:F").ColumnWidth = 15.57
Columns("G:G").ColumnWidth = 20.14
Columns("G:G").ColumnWidth = 20
Columns("G:G").ColumnWidth = 20.29
Columns("I:I").ColumnWidth = 16.86
Columns("J:J").ColumnWidth = 9.57
Cells.Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("G8").Select
Columns("M:M").ColumnWidth = 17.86
Columns("M:M").ColumnWidth = 16.29
Columns("O:O").ColumnWidth = 11.29
Rows("1:1").EntireRow.AutoFit
Columns("P:P").ColumnWidth = 7.86
Columns("P:P").ColumnWidth = 7.14
Columns("P:P").ColumnWidth = 7
Columns("P:P").ColumnWidth = 6.86
Columns("P:P").ColumnWidth = 6.71
Columns("P:P").ColumnWidth = 6.86
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = True
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 71
.PrintErrors = xlPrintErrorsDisplayed
End With
Dim cur1 As Range
Dim cur2 As Range
Set cur1 = Range("A2")
Windows("today.xls").Activate
Set cur2 = Range("A2")
Windows("tomorrow.xls").Activate
Dim i As Integer
i = Application.WorksheetFunction.CountA(Range("A:A"))
Dim range1 As Range
Do While (i > 1)
Windows("today.xls").Activate
cur2.Select
If (Selection.Interior.ColorIndex = 37) Then
Windows("tomorrow.xls").Activate
Set range1 = Cells.Find(Selection)
If Not range1 Is Nothing Then
MsgBox "round " & i
range1.EntireRow.ColorIndex = 37
End If
ElseIf (Selection.Interior.ColorIndex = 35) Then
Windows("tomorrow.xls").Activate
Set range1 = Cells.Find(Selection)
If Not range1 Is Nothing Then
MsgBox "round " & i
range1.EntireRow.ColorIndex = 35
End If
' ElseIf (Selection.Interior.ColorIndex = 35) Then
' Range(cur1 & ":" & cur1.Offset(0, 21)).ColorIndex = 35
End If
Set cur1 = cur1.Offset(1, 0)
Set cur2 = cur2.Offset(1, 0)
i = i - 1
Loop
Application.ScreenUpdating = True
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER