LutonBarry
07-21-2014, 05:17 AM
Folks I hope can help and at the same time give you a giggle at my attempts at coding. I have a Project that runs a few subs. In two of then a combi box asks the user to open a particualr report and the first one in SUB Import () works fine it appears on the screen and stays there untill the user selects Yes or No. The second Combi box in Sub PrepareAllSheetsImport() quickly flashes onto the screen and disappears before a Yes/No selection. Any ideas I've run it without any Application.screenUpdating and Displayalerts but they have no effect.
Apologies for the length of code but I thought it useful to include all the events between the two Combi Boxes.
CompleteRtssReportJob()
' CompleteJob Macro
CleanUp
Import
FilterRTSS
DeleteColumns
WrkGrpShortNameAllCalls
PrepareExportCraigo
PrepareAllSheetImport
Private Sub CleanUp()
' Cleans theworkbook of data from previous days activity.
Dim arr, a
Dim LR As Long
arr =Array("Import", "Open", "Closed","New", "RTSS", "Yesterday")
For Each a In arr
With Sheets(a)
LR = .Cells.Find("*", After:=.Cells(1, 1),SearchDirection:=xlPrevious).Row
.Rows("2:" & LR).Delete
End With
Next
Sheets("Today").Select
Cells.FormatConditions.Delete
Sheets("Yesterday").Select
Cells.FormatConditions.Delete
Sheets("Import").Select
Cells.FormatConditions.Delete
Sheets("Open").Select
Cells.FormatConditions.Delete
Sheets("Closed").Select
Cells.FormatConditions.Delete
Sheets("New").Select
Cells.FormatConditions.Delete
Application.DisplayAlerts = False
Sheets("Today").Select
Rows("2:2").Select
Range(Selection,Selection.End(xlDown)).Delete Shift:=xlUp
Rows("1:1").Select
Selection.Copy
Sheets(Array("Import", "Yesterday", "Open","Closed", "New")).Select
Sheets("Yesterday").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets(Array("All", "RAWData")).Delete
Application.DisplayAlerts = True
End Sub
Private Sub Import()
'
' Import Macro
'
'
Dim myCheck AsInteger
myCheck =MsgBox("Brought to you courtesy of the Luton Outlaws. Locate and opentoday's Dashboard Report. Continue?", vbYesNo)
Dim myWorkbook AsWorkbook
myFile =Application.GetOpenFilename()
Workbooks.OpenFilename:=myFile
Set myWorkbook =ActiveWorkbook
Application.Calculation = xlAutomatic
Selection.AutoFilter
Application.DisplayAlerts = False
Sheets("RawData").CopyBefore:=Workbooks("RTSS Reporting.xlsm").Sheets _
(1)
myWorkbook.CloseSaveChanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = False
End Sub
Private Sub FilterRTSS()
'
' FilterIngrid Macro
'
' Filters out unwanted data to leaveIgrid's data.
'
Sheets("RawData").Select
Application.DisplayAlerts = False
On Error ResumeNext
Selection.AutoFilter
Application.DisplayAlerts = True
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AH$1797").AutoFilter Field:=3,Criteria1:="=RTSS*" _
, Operator:=xlAnd, Criteria2:="<>*-*"
ActiveSheet.Range("$A$1:$AH$1707").AutoFilter Field:=11, Criteria1:=_
"<>*audit*", Operator:=xlAnd
Cells.Select
Range("C1").Activate
Selection.Copy
Sheets("RTSS").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Private Sub DeleteColumns()
'
' DeleteColumns Macro
'
'
Sheets("RTSS").Select
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B:B,D:H,J:J,L:T,W:AM").Delete Shift:=x1ToLeft
Range("A1").Select
End Sub
Private Sub WrkGrpShortName()
'
' WrkGrpShortName Macro
'
' Edits Workgroup names to shorttext
'
Sheets("RTSS").Select
Columns("C:C").InsertShift:=xlToLeft, CopyOrigin:=xlFormatFromLeftOrA
Range("C1").Select
ActiveCell.FormulaR1C1 = "To Workgroup"
Columns("D:D").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Range("C2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'Look upsheet'!C[-2]:C[-1],2,FALSE)"
Range("C3").Select
Selection.CurrentRegion.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
Range("C2").Select
Range(Selection,Selection.End(xlDown)).Select
Selection.FillDown
Columns("C:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Delete Shift:=xlToLeft
Columns("C:C").Delete Shift:=xlToLeft
Cells.Select
Cells.EntireColumn.Autofit
Range("A1").Select
End Sub
Private Sub AllCalls()
'
' AllCalls Macro
'
'
Sheets("RTSS").Select
Selection.CurrentRegion.Select
Selection.Copy
Sheets("Import").Select
Range("B2").Select
ActiveSheet.Paste
Rows("2:2").Select
Selection.DeleteShift:=xlUp
Range("A2").Select
End Sub
Private Sub PrepareExportCraigo()
'
' PrepareExportCraigo Macro
'
'
Columns("C:C").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Range("C1").Select
ActiveCell.FormulaR1C1 = "Location"
WithActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
' .Strikethrough = False
'.Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
'.ThemeColor =xlThemeColorDark1
' .TintAndShade = 0
' .ThemeFont = xlThemeFontMinor
End With
Columns("C:C").EntireColumn.Autofit
Columns("D:D").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2").CurrentRegion.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1= "Today"
WithSelection.Characters(Start:=1, Length:=5).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
'.Strikethrough = False
'.Superscript = False
'.Subscript = False
' .OutlineFont = False
'.Shadow = False
'.Underline = xlUnderlineStyleNone
.ThemeColor = 1
'.TintAndShade = 0
'.ThemeFont = xlThemeFontMinor
Columns("D:D").Delete Shift:=xlToLeft
Range("A2").Select
End With
End Sub
Private Sub PrepareAllSheetImport()
'
' PrepareAllSheetImport Macro
'
'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Dim myCheck AsInteger
myCheck =MsgBox("Locate and open previous days Call Report. Continue?",vbYesNo)
Dim myWorkbook AsWorkbook
myFile =Application.GetOpenFilename()
Workbooks.OpenFilename:=myFile
Set myWorkbook =ActiveWorkbook
Sheets("Open").Select
Selection.AutoFilter
Sheets("Open").Name = "All"
Sheets("All").Select
Sheets("All").Copy Before:=Workbooks("RTSSReporting.xlsm").Sheets("Open")
Application.DisplayAlerts = False
myWorkbook.CloseSaveChanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating= False
Sheets("ALL").Select
Columns("C:C").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Columns("A:A").Delete Shift:=xlToLeft
Columns("A:A").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").FormulaR1C1 = "Day"
Range("B1").Copy
Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A2").Select
Selection.CurrentRegion.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "Yesterday"
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Columns("C:C").Delete Shift:=xlToLeft
End Sub
Apologies for the length of code but I thought it useful to include all the events between the two Combi Boxes.
CompleteRtssReportJob()
' CompleteJob Macro
CleanUp
Import
FilterRTSS
DeleteColumns
WrkGrpShortNameAllCalls
PrepareExportCraigo
PrepareAllSheetImport
Private Sub CleanUp()
' Cleans theworkbook of data from previous days activity.
Dim arr, a
Dim LR As Long
arr =Array("Import", "Open", "Closed","New", "RTSS", "Yesterday")
For Each a In arr
With Sheets(a)
LR = .Cells.Find("*", After:=.Cells(1, 1),SearchDirection:=xlPrevious).Row
.Rows("2:" & LR).Delete
End With
Next
Sheets("Today").Select
Cells.FormatConditions.Delete
Sheets("Yesterday").Select
Cells.FormatConditions.Delete
Sheets("Import").Select
Cells.FormatConditions.Delete
Sheets("Open").Select
Cells.FormatConditions.Delete
Sheets("Closed").Select
Cells.FormatConditions.Delete
Sheets("New").Select
Cells.FormatConditions.Delete
Application.DisplayAlerts = False
Sheets("Today").Select
Rows("2:2").Select
Range(Selection,Selection.End(xlDown)).Delete Shift:=xlUp
Rows("1:1").Select
Selection.Copy
Sheets(Array("Import", "Yesterday", "Open","Closed", "New")).Select
Sheets("Yesterday").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets(Array("All", "RAWData")).Delete
Application.DisplayAlerts = True
End Sub
Private Sub Import()
'
' Import Macro
'
'
Dim myCheck AsInteger
myCheck =MsgBox("Brought to you courtesy of the Luton Outlaws. Locate and opentoday's Dashboard Report. Continue?", vbYesNo)
Dim myWorkbook AsWorkbook
myFile =Application.GetOpenFilename()
Workbooks.OpenFilename:=myFile
Set myWorkbook =ActiveWorkbook
Application.Calculation = xlAutomatic
Selection.AutoFilter
Application.DisplayAlerts = False
Sheets("RawData").CopyBefore:=Workbooks("RTSS Reporting.xlsm").Sheets _
(1)
myWorkbook.CloseSaveChanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = False
End Sub
Private Sub FilterRTSS()
'
' FilterIngrid Macro
'
' Filters out unwanted data to leaveIgrid's data.
'
Sheets("RawData").Select
Application.DisplayAlerts = False
On Error ResumeNext
Selection.AutoFilter
Application.DisplayAlerts = True
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AH$1797").AutoFilter Field:=3,Criteria1:="=RTSS*" _
, Operator:=xlAnd, Criteria2:="<>*-*"
ActiveSheet.Range("$A$1:$AH$1707").AutoFilter Field:=11, Criteria1:=_
"<>*audit*", Operator:=xlAnd
Cells.Select
Range("C1").Activate
Selection.Copy
Sheets("RTSS").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Private Sub DeleteColumns()
'
' DeleteColumns Macro
'
'
Sheets("RTSS").Select
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B:B,D:H,J:J,L:T,W:AM").Delete Shift:=x1ToLeft
Range("A1").Select
End Sub
Private Sub WrkGrpShortName()
'
' WrkGrpShortName Macro
'
' Edits Workgroup names to shorttext
'
Sheets("RTSS").Select
Columns("C:C").InsertShift:=xlToLeft, CopyOrigin:=xlFormatFromLeftOrA
Range("C1").Select
ActiveCell.FormulaR1C1 = "To Workgroup"
Columns("D:D").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Range("C2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'Look upsheet'!C[-2]:C[-1],2,FALSE)"
Range("C3").Select
Selection.CurrentRegion.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
Range("C2").Select
Range(Selection,Selection.End(xlDown)).Select
Selection.FillDown
Columns("C:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Delete Shift:=xlToLeft
Columns("C:C").Delete Shift:=xlToLeft
Cells.Select
Cells.EntireColumn.Autofit
Range("A1").Select
End Sub
Private Sub AllCalls()
'
' AllCalls Macro
'
'
Sheets("RTSS").Select
Selection.CurrentRegion.Select
Selection.Copy
Sheets("Import").Select
Range("B2").Select
ActiveSheet.Paste
Rows("2:2").Select
Selection.DeleteShift:=xlUp
Range("A2").Select
End Sub
Private Sub PrepareExportCraigo()
'
' PrepareExportCraigo Macro
'
'
Columns("C:C").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Range("C1").Select
ActiveCell.FormulaR1C1 = "Location"
WithActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
' .Strikethrough = False
'.Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
'.ThemeColor =xlThemeColorDark1
' .TintAndShade = 0
' .ThemeFont = xlThemeFontMinor
End With
Columns("C:C").EntireColumn.Autofit
Columns("D:D").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Range("A2").CurrentRegion.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1= "Today"
WithSelection.Characters(Start:=1, Length:=5).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
'.Strikethrough = False
'.Superscript = False
'.Subscript = False
' .OutlineFont = False
'.Shadow = False
'.Underline = xlUnderlineStyleNone
.ThemeColor = 1
'.TintAndShade = 0
'.ThemeFont = xlThemeFontMinor
Columns("D:D").Delete Shift:=xlToLeft
Range("A2").Select
End With
End Sub
Private Sub PrepareAllSheetImport()
'
' PrepareAllSheetImport Macro
'
'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Dim myCheck AsInteger
myCheck =MsgBox("Locate and open previous days Call Report. Continue?",vbYesNo)
Dim myWorkbook AsWorkbook
myFile =Application.GetOpenFilename()
Workbooks.OpenFilename:=myFile
Set myWorkbook =ActiveWorkbook
Sheets("Open").Select
Selection.AutoFilter
Sheets("Open").Name = "All"
Sheets("All").Select
Sheets("All").Copy Before:=Workbooks("RTSSReporting.xlsm").Sheets("Open")
Application.DisplayAlerts = False
myWorkbook.CloseSaveChanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating= False
Sheets("ALL").Select
Columns("C:C").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Columns("A:A").Delete Shift:=xlToLeft
Columns("A:A").Insert Shift:=xlToRight,CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").FormulaR1C1 = "Day"
Range("B1").Copy
Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A2").Select
Selection.CurrentRegion.Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "Yesterday"
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Columns("C:C").Delete Shift:=xlToLeft
End Sub