Poundland
01-14-2016, 03:36 AM
Guys,
I have written some code below, which works and does as intended with one exception, that of the Text Box coding, the Text Box fails to appear on the worksheet whilst the code is in operation. yet if I break code, switch workbooks and back again the text box is displayed.
I have tried moving the text box code to different places within the code structure and played with Screenupdating On and Off but still to no avail.
Is there something obvious that I am missing?
Sub Exceptions()
' Define DateVariables
Dim Dte As Range, DteDestn As Range, UserInput As Long
' Define Hierarchy Variables
Dim Msku As Range, Dept As Range, SubD As Range, Class As Range, SClass As Range, MskuDesc As Range
' Define Hierarchy Destination Variables
Dim MskuDestn As Range, DeptDestn As Range, SubDDestn As Range, ClassDestn As Range, SClassDestn As Range
Dim MskuDescDestn As Range
' Define Workbook and Worksheet Variables
Dim Wkb As Workbook, WkbNew As Workbook, Active As Workbook, ActList As Worksheet, LineF As Worksheet, NewS As Worksheet
Dim Exceptions As Range, Excep(1 To 6) As Range
' Define Mail Out Variables
Dim OutApp As Object, OutMail As Object
Chk = InputBox("Running this Macro will disable all other Excel workbooks from being accessed until it has completed. Do you want to continue (y) / (n)")
If Chk = 0 Or Chk = n Then
MsgBox ("You have chosen to not run this macro")
Exit Sub
Else
End If
' Create a text box on the active worksheet.
' (Horizontal position, Vertical posiiton, Box Length, Box Height)
ActiveSheet.TextBoxes.Add(215, 150, 500, 100).Select
' Store the name of Worksheet in variable StoreWSNM.
StoreWSNM = ActiveSheet.Name
' Store the name of Text Box in variable StoreNM
StoreNM = Selection.Name
' Set the Font and Border properties of the text box.
With Selection
With Selection.Characters.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 20
End With
With Selection.Border
.LineStyle = xlContinuous
.ColorIndex = 1
.Weight = xlThick
End With
'Set round corners for the text box.
.RoundedCorners = True
'Set message text color to black.
.Interior.ColorIndex = 15
'Assign message text to the text box.
.Characters.Text = "Please Wait... The Exception report is compiling. You will be unable to use Excel until this has finished!"
End With
' Requests user for number of weeks to investigate exceptions over
On Error Resume Next
UserInput = InputBox("Please enter the number of weeks that you want to report exceptions over? Min(1), Max (48)" _
, "Weeks Exception Selector")
On Error GoTo 0
If UserInput = 0 Then
UserInput = 55
Else
UserInput = UserInput + 6
End If
Application.ScreenUpdating = False
' set Workbook and Worksheet objects
Set Wkb = ThisWorkbook
Set LineF = Wkb.Sheets("Lineflow")
Set WkbNew = Workbooks.Add
Set NewS = WkbNew.Sheets("Sheet1")
Set Active = Workbooks("Active Skus - Developments")
Set ActList = Active.Sheets("Active Sku List")
' set hierarchy destination objects
Set DeptDestn = NewS.Cells(2, 1)
Set SubDDestn = NewS.Cells(2, 2)
Set ClassDestn = NewS.Cells(2, 3)
Set SClassDestn = NewS.Cells(2, 4)
Set MskuDestn = NewS.Cells(2, 5)
Set MskuDescDestn = NewS.Cells(2, 6)
' set exception destinations objects
Set DteDestn = NewS.Cells(2, 7)
Set Excep(1) = NewS.Cells(2, 8)
Set Excep(2) = NewS.Cells(2, 9)
Set Excep(3) = NewS.Cells(2, 10)
Set Excep(4) = NewS.Cells(2, 11)
Set Excep(5) = NewS.Cells(2, 12)
Set Excep(6) = NewS.Cells(2, 13)
' creates headers on new workbook
With NewS.Range("A1:L1")
.Cells(1, 1).Value = "Department"
.Cells(1, 2).Value = "Sub Department"
.Cells(1, 3).Value = "Class"
.Cells(1, 4).Value = "Sub Class"
.Cells(1, 5).Value = "Master Sku"
.Cells(1, 6).Value = "MSKU Desc"
.Cells(1, 7).Value = "First Exception Date"
.Cells(1, 8).Value = "1st Exception"
.Cells(1, 9).Value = "2nd Exception"
.Cells(1, 10).Value = "3rd Exception"
.Cells(1, 11).Value = "4th Exception"
.Cells(1, 12).Value = "5th Exception"
.Cells(1, 13).Value = "6th Exception"
End With
LineF.Activate
Application.ScreenUpdating = False
' For Next routine to cycle through Master Skus on Active Sku List
a = 2 ' Variable used to offset row number for destinations
For Each Msku In ActList.Range(ActList.Cells(5, 3), ActList.Cells(5, 3).End(xlDown)).Cells
Application.ScreenUpdating = False
LineF.Cells(5, 6) = Msku.Value ' PLaces Master Sku into Lineflow
Application.ScreenUpdating = False
Set Dept = LineF.Cells(5, 9) ' Captures Hierarchy data from Lineflow update
Set SubD = LineF.Cells(5, 11)
Set Class = LineF.Cells(5, 13)
Set SClass = LineF.Cells(5, 15)
Set MskuDesc = LineF.Cells(5, 7)
Col = 6
' clears exception variables
Excep(1) = ""
Excep(2) = ""
Excep(3) = ""
Excep(4) = ""
Excep(5) = ""
Excep(6) = ""
' Loops through exception range until valid value is found for each exception
Do
Col = Col + 1
For Rw = 75 To 80
Set Exceptions = LineF.Cells(Rw, Col)
If Exceptions.Value <> "" Then
Select Case Excep(1).Value <> "" ' Case routine cycles through each exception and assigns where is nothing
Case False
Excep(1) = Exceptions.Value
Set Dte = LineF.Cells(7, Exceptions.Column) ' captures first exception date
DeptDestn = Dept.Value
SubDDestn = SubD.Value
ClassDestn = Class.Value
SClassDestn = SClass.Value
MskuDestn = Msku.Value
MskuDescDestn = MskuDesc.Value
DteDestn = Dte.Value
a = a + 1 ' Changes the row variable for the destinations
GoTo bb
Case True
End Select
Select Case Excep(2).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(2) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(3).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(3) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(4).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(4) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(5).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(5) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(6).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value _
Or Excep(5).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(6) = Exceptions.Value
GoTo bb
Case True
End Select
'Rw = 80
Else
End If
bb:
Next Rw
' Loops until the user defined weeks have been reached or until the Last Exception place has beem filled.
Loop Until Col = UserInput Or Excep(6).Value <> ""
' re-sets the destination Variables
' set hierarchy destination objects
Set DeptDestn = NewS.Cells(a, 1)
Set SubDDestn = NewS.Cells(a, 2)
Set ClassDestn = NewS.Cells(a, 3)
Set SClassDestn = NewS.Cells(a, 4)
Set MskuDestn = NewS.Cells(a, 5)
Set MskuDescDestn = NewS.Cells(a, 6)
' set exception destinations objects
Set DteDestn = NewS.Cells(a, 7)
Set Excep(1) = NewS.Cells(a, 8)
Set Excep(2) = NewS.Cells(a, 9)
Set Excep(3) = NewS.Cells(a, 10)
Set Excep(4) = NewS.Cells(a, 11)
Set Excep(5) = NewS.Cells(a, 12)
Set Excep(6) = NewS.Cells(a, 13)
Next Msku
NewS.Activate
With NewS.Range("A1:L1")
.AutoFilter
End With
With NewS.UsedRange
.Columns.AutoFit
End With
Application.DisplayAlerts = False
WkbNew.SaveAs ("I:\H914 Development and Supply Chain\Lineflow\Developments Exceptions\Developments Exceptions " & Format(Now, "yyyy.mm.dd") & " .xlsx")
WkbNew.Close False
Application.DisplayAlerts = True
LineF.Activate
LineF.Cells(5, 6) = "" ' Clears Master Sku into Lineflow
' Attempt to close the message box down
' Makes sure the proper Worksheet is selected.
Worksheets(StoreWSNM).Select
' Makes sure the proper text box is selected.
ActiveSheet.TextBoxes(StoreNM).Select
' Deletes the Please Wait... text box.
Selection.Delete
Application.ScreenUpdating = True
MsgBox ("The Exception Report will now be emailed to all parties")
'Mail Routine
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "scott.atkinson@poundland.co.uk"
.cc = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add ("I:\H914 Development and Supply Chain\Lineflow\Developments Exceptions\Developments Exceptions " & Format(Now, "yyyy.mm.dd") & " .xlsx")
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I have written some code below, which works and does as intended with one exception, that of the Text Box coding, the Text Box fails to appear on the worksheet whilst the code is in operation. yet if I break code, switch workbooks and back again the text box is displayed.
I have tried moving the text box code to different places within the code structure and played with Screenupdating On and Off but still to no avail.
Is there something obvious that I am missing?
Sub Exceptions()
' Define DateVariables
Dim Dte As Range, DteDestn As Range, UserInput As Long
' Define Hierarchy Variables
Dim Msku As Range, Dept As Range, SubD As Range, Class As Range, SClass As Range, MskuDesc As Range
' Define Hierarchy Destination Variables
Dim MskuDestn As Range, DeptDestn As Range, SubDDestn As Range, ClassDestn As Range, SClassDestn As Range
Dim MskuDescDestn As Range
' Define Workbook and Worksheet Variables
Dim Wkb As Workbook, WkbNew As Workbook, Active As Workbook, ActList As Worksheet, LineF As Worksheet, NewS As Worksheet
Dim Exceptions As Range, Excep(1 To 6) As Range
' Define Mail Out Variables
Dim OutApp As Object, OutMail As Object
Chk = InputBox("Running this Macro will disable all other Excel workbooks from being accessed until it has completed. Do you want to continue (y) / (n)")
If Chk = 0 Or Chk = n Then
MsgBox ("You have chosen to not run this macro")
Exit Sub
Else
End If
' Create a text box on the active worksheet.
' (Horizontal position, Vertical posiiton, Box Length, Box Height)
ActiveSheet.TextBoxes.Add(215, 150, 500, 100).Select
' Store the name of Worksheet in variable StoreWSNM.
StoreWSNM = ActiveSheet.Name
' Store the name of Text Box in variable StoreNM
StoreNM = Selection.Name
' Set the Font and Border properties of the text box.
With Selection
With Selection.Characters.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 20
End With
With Selection.Border
.LineStyle = xlContinuous
.ColorIndex = 1
.Weight = xlThick
End With
'Set round corners for the text box.
.RoundedCorners = True
'Set message text color to black.
.Interior.ColorIndex = 15
'Assign message text to the text box.
.Characters.Text = "Please Wait... The Exception report is compiling. You will be unable to use Excel until this has finished!"
End With
' Requests user for number of weeks to investigate exceptions over
On Error Resume Next
UserInput = InputBox("Please enter the number of weeks that you want to report exceptions over? Min(1), Max (48)" _
, "Weeks Exception Selector")
On Error GoTo 0
If UserInput = 0 Then
UserInput = 55
Else
UserInput = UserInput + 6
End If
Application.ScreenUpdating = False
' set Workbook and Worksheet objects
Set Wkb = ThisWorkbook
Set LineF = Wkb.Sheets("Lineflow")
Set WkbNew = Workbooks.Add
Set NewS = WkbNew.Sheets("Sheet1")
Set Active = Workbooks("Active Skus - Developments")
Set ActList = Active.Sheets("Active Sku List")
' set hierarchy destination objects
Set DeptDestn = NewS.Cells(2, 1)
Set SubDDestn = NewS.Cells(2, 2)
Set ClassDestn = NewS.Cells(2, 3)
Set SClassDestn = NewS.Cells(2, 4)
Set MskuDestn = NewS.Cells(2, 5)
Set MskuDescDestn = NewS.Cells(2, 6)
' set exception destinations objects
Set DteDestn = NewS.Cells(2, 7)
Set Excep(1) = NewS.Cells(2, 8)
Set Excep(2) = NewS.Cells(2, 9)
Set Excep(3) = NewS.Cells(2, 10)
Set Excep(4) = NewS.Cells(2, 11)
Set Excep(5) = NewS.Cells(2, 12)
Set Excep(6) = NewS.Cells(2, 13)
' creates headers on new workbook
With NewS.Range("A1:L1")
.Cells(1, 1).Value = "Department"
.Cells(1, 2).Value = "Sub Department"
.Cells(1, 3).Value = "Class"
.Cells(1, 4).Value = "Sub Class"
.Cells(1, 5).Value = "Master Sku"
.Cells(1, 6).Value = "MSKU Desc"
.Cells(1, 7).Value = "First Exception Date"
.Cells(1, 8).Value = "1st Exception"
.Cells(1, 9).Value = "2nd Exception"
.Cells(1, 10).Value = "3rd Exception"
.Cells(1, 11).Value = "4th Exception"
.Cells(1, 12).Value = "5th Exception"
.Cells(1, 13).Value = "6th Exception"
End With
LineF.Activate
Application.ScreenUpdating = False
' For Next routine to cycle through Master Skus on Active Sku List
a = 2 ' Variable used to offset row number for destinations
For Each Msku In ActList.Range(ActList.Cells(5, 3), ActList.Cells(5, 3).End(xlDown)).Cells
Application.ScreenUpdating = False
LineF.Cells(5, 6) = Msku.Value ' PLaces Master Sku into Lineflow
Application.ScreenUpdating = False
Set Dept = LineF.Cells(5, 9) ' Captures Hierarchy data from Lineflow update
Set SubD = LineF.Cells(5, 11)
Set Class = LineF.Cells(5, 13)
Set SClass = LineF.Cells(5, 15)
Set MskuDesc = LineF.Cells(5, 7)
Col = 6
' clears exception variables
Excep(1) = ""
Excep(2) = ""
Excep(3) = ""
Excep(4) = ""
Excep(5) = ""
Excep(6) = ""
' Loops through exception range until valid value is found for each exception
Do
Col = Col + 1
For Rw = 75 To 80
Set Exceptions = LineF.Cells(Rw, Col)
If Exceptions.Value <> "" Then
Select Case Excep(1).Value <> "" ' Case routine cycles through each exception and assigns where is nothing
Case False
Excep(1) = Exceptions.Value
Set Dte = LineF.Cells(7, Exceptions.Column) ' captures first exception date
DeptDestn = Dept.Value
SubDDestn = SubD.Value
ClassDestn = Class.Value
SClassDestn = SClass.Value
MskuDestn = Msku.Value
MskuDescDestn = MskuDesc.Value
DteDestn = Dte.Value
a = a + 1 ' Changes the row variable for the destinations
GoTo bb
Case True
End Select
Select Case Excep(2).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(2) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(3).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(3) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(4).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(4) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(5).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(5) = Exceptions.Value
GoTo bb
Case True
End Select
Select Case Excep(6).Value <> ""
Case False
If Excep(1).Value = Exceptions.Value Or Excep(2).Value = Exceptions.Value _
Or Excep(3).Value = Exceptions.Value Or Excep(4).Value = Exceptions.Value _
Or Excep(5).Value = Exceptions.Value Then
GoTo bb
Else
End If
Excep(6) = Exceptions.Value
GoTo bb
Case True
End Select
'Rw = 80
Else
End If
bb:
Next Rw
' Loops until the user defined weeks have been reached or until the Last Exception place has beem filled.
Loop Until Col = UserInput Or Excep(6).Value <> ""
' re-sets the destination Variables
' set hierarchy destination objects
Set DeptDestn = NewS.Cells(a, 1)
Set SubDDestn = NewS.Cells(a, 2)
Set ClassDestn = NewS.Cells(a, 3)
Set SClassDestn = NewS.Cells(a, 4)
Set MskuDestn = NewS.Cells(a, 5)
Set MskuDescDestn = NewS.Cells(a, 6)
' set exception destinations objects
Set DteDestn = NewS.Cells(a, 7)
Set Excep(1) = NewS.Cells(a, 8)
Set Excep(2) = NewS.Cells(a, 9)
Set Excep(3) = NewS.Cells(a, 10)
Set Excep(4) = NewS.Cells(a, 11)
Set Excep(5) = NewS.Cells(a, 12)
Set Excep(6) = NewS.Cells(a, 13)
Next Msku
NewS.Activate
With NewS.Range("A1:L1")
.AutoFilter
End With
With NewS.UsedRange
.Columns.AutoFit
End With
Application.DisplayAlerts = False
WkbNew.SaveAs ("I:\H914 Development and Supply Chain\Lineflow\Developments Exceptions\Developments Exceptions " & Format(Now, "yyyy.mm.dd") & " .xlsx")
WkbNew.Close False
Application.DisplayAlerts = True
LineF.Activate
LineF.Cells(5, 6) = "" ' Clears Master Sku into Lineflow
' Attempt to close the message box down
' Makes sure the proper Worksheet is selected.
Worksheets(StoreWSNM).Select
' Makes sure the proper text box is selected.
ActiveSheet.TextBoxes(StoreNM).Select
' Deletes the Please Wait... text box.
Selection.Delete
Application.ScreenUpdating = True
MsgBox ("The Exception Report will now be emailed to all parties")
'Mail Routine
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "scott.atkinson@poundland.co.uk"
.cc = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add ("I:\H914 Development and Supply Chain\Lineflow\Developments Exceptions\Developments Exceptions " & Format(Now, "yyyy.mm.dd") & " .xlsx")
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub