Text Box not Displaying

[Poundland]

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

[Bob Phillips]

Post the workbook, can't help without seeing the actual objects. ALso tell us what steps to reproduce the issue.

[SamT]

I did not see any obvious errors or reasons the Box didn't show. Unless you are talking about when running the sub from VBA, then Breaking it to look at the Worksheet.

You had the sub and a Variable with the same name. Bad dog, no biscuits for you. I rewrote that horrible Select Case routine you had, which got rid of that variable. I also changed all the Range Variable names to use RPN, ("rngDte As Range, rngDteDestn As Range")

Then I went thru the code and made suggestions (In Comment) as to where a logical place to move the code to a sub routine would be. This would make it much easier to design and trouble shoot. the main routine, "Exceptions," would have very little actual code in it. IT would mostly be calling sub routines that only did a particular small bit of work.

A lot of variables still have not yet been declared. I suggest that you put "Option Explicit" at the top of all you code p[ages, and Compile your code often.
Option Explicit

Sub Exceptions()

'*******Module Variables************* Move to below Optiion Explicit*********
' Define DateVariables
Dim rngDte As Range, rngDteDestn As Range
' Define Hierarchy Variables
Dim rngMsku As Range, rngDept As Range, rngSubD As Range, rngClass As Range
Dim rngSClass As Range, rngMskuDesc As Range
' Define Hierarchy Destination Variables
Dim rngMskuDestn As Range, rngDeptDestn As Range, rngSubDDestn As Range
Dim rngClassDestn As Range, rngSClassDestn As Range, rngMskuDescDestn 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 rngExceptions As Range, rngExcep(1 To 6) As Range 'rngExeptions not used in my changes
' Define Mail Out Variables
Dim OutApp As Object, OutMail As Object
'**End


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


'****************Sub-Procedure**********
' 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
'**End

'***************Sub-Procedure**********
' Requests user for number of weeks to investigate rngExceptions over
On Error Resume Next
UserInput = InputBox("Please enter the number of weeks that you want to report rngExceptions over? Min(1), Max (48)" _
, "Weeks Exception Selector")
On Error GoTo 0

If UserInput = 0 Then
UserInput = 55
Else
UserInput = UserInput + 6
End If
'**End

'***********Sub-Procedure "Sub Initialize()" ***********
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 rngDeptDestn = NewS.Cells(2, 1)
Set rngSubDDestn = NewS.Cells(2, 2)
Set rngClassDestn = NewS.Cells(2, 3)
Set rngSClassDestn = NewS.Cells(2, 4)
Set rngMskuDestn = NewS.Cells(2, 5)
Set rngMskuDescDestn = NewS.Cells(2, 6)
' set exception destinations objects
Set rngDteDestn = NewS.Cells(2, 7)
Set rngExcep(1) = NewS.Cells(2, 8)
Set rngExcep(2) = NewS.Cells(2, 9)
Set rngExcep(3) = NewS.Cells(2, 10)
Set rngExcep(4) = NewS.Cells(2, 11)
Set rngExcep(5) = NewS.Cells(2, 12)
Set rngExcep(6) = NewS.Cells(2, 13)

'**************Sub Function********
' 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 = "rngClass"
.Cells(1, 4).Value = "Sub rngClass"
.Cells(1, 5).Value = "Master Sku"
.Cells(1, 6).Value = "rngMsku 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
'**End Sub
LineF.Activate
'**End

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

'******************** rngMsku Function************
For Each rngMsku In ActList.Range(ActList.Cells(5, 3), ActList.Cells(5, 3).End(xlDown)).Cells
Application.ScreenUpdating = False
LineF.Cells(5, 6) = rngMsku.Value ' PLaces Master Sku into Lineflow
Application.ScreenUpdating = False
Set rngDept = LineF.Cells(5, 9) ' Captures Hierarchy data from Lineflow update
Set rngSubD = LineF.Cells(5, 11)
Set rngClass = LineF.Cells(5, 13)
Set rngSClass = LineF.Cells(5, 15)
Set rngMskuDesc = LineF.Cells(5, 7)
Col = 6


'*************Sub-Procedure**********
' clears exception variables
rngExcep(1) = ""
rngExcep(2) = ""
rngExcep(3) = ""
rngExcep(4) = ""
rngExcep(5) = ""
rngExcep(6) = ""

' Loops through exception range until valid value is found for each exception


Dim iExcep As Long, iTest As Long
With LineF
Do
Col = Col + 1
For rw = 75 To 80
If .Cells(rw, Col) <> "" Then
'For routine cycles through each exception and assigns where is nothing
For iExcep = 1 To 6
If rngExcep(iExcep) = "" Then
For iTest = 1 To iExcep - 1 'Won't test if iExcep = 1
If rngExcep(iExcep) = rngExcep(iTest) Or rngExcep(iExcep) = .Cells(rw, Col) Then GoTo bb
Next iTest
rngExcep(iExcep) = .Cells(rw, Col)
If iExcep = 1 And rngDte = "" Then
Set rngDte = LineF.Cells(7, Col) ' captures first exception date
rngDeptDestn = rngDept.Value
rngSubDDestn = rngSubD.Value
rngClassDestn = rngClass.Value
rngSClassDestn = rngSClass.Value
rngMskuDestn = rngMsku.Value
rngMskuDescDestn = rngMskuDesc.Value
rngDteDestn = rngDte.Value
'a is not Declared
a = a + 1 ' Changes the row variable for the destinations
End If
GoTo bb
End If
Next iExcep
End If
bb:
Next rw

Loop Until Col = UserInput Or rngExcep(6).Value <> ""
End With
'**End

'********Sub-Procedure*************
' re-sets the destination Variables
' set hierarchy destination objects
Set rngDeptDestn = NewS.Cells(a, 1)
Set rngSubDDestn = NewS.Cells(a, 2)
Set rngClassDestn = NewS.Cells(a, 3)
Set rngSClassDestn = NewS.Cells(a, 4)
Set rngMskuDestn = NewS.Cells(a, 5)
Set rngMskuDescDestn = NewS.Cells(a, 6)
' set exception destinations objects
Set rngDteDestn = NewS.Cells(a, 7)
Set rngExcep(1) = NewS.Cells(a, 8)
Set rngExcep(2) = NewS.Cells(a, 9)
Set rngExcep(3) = NewS.Cells(a, 10)
Set rngExcep(4) = NewS.Cells(a, 11)
Set rngExcep(5) = NewS.Cells(a, 12)
Set rngExcep(6) = NewS.Cells(a, 13)

Next rngMsku
'** End rngMsku sub-Procedure

'*********************Sub-Procedure
NewS.Activate

With NewS.Range("A1:L1")
.AutoFilter
End With

With NewS.UsedRange
.Columns.AutoFit
End With
'**End

Application.DisplayAlerts = False
WkbNew.SaveAs ("I:\H914 Development and Supply Chain\Lineflow\Developments rngExceptions\Developments rngExceptions " & Format(Now, "yyyy.mm.dd") & " .xlsx")
WkbNew.Close False
Application.DisplayAlerts = True

'******************Procedure***********
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
'**End

Application.ScreenUpdating = True
MsgBox ("The Exception Report will now be emailed to all parties")
'Mail Routine

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'*******Sub-Proceduire*******
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 rngExceptions\Developments rngExceptions " & 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
'**End

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

[mikerickson]

Put
Application.ScreenUpdating = True into the code when you want the text box to be visible. Sometimes you have to force that to see changes in shapes or text boxes.

[Poundland]

Sam T, thank you for your help on this buddy, when it comes to VBA writing I am still pretty green but learning all the time.

I will certainly take all your advice on board.

[snb]

NewS.Range("A1:L1")=split("Department_Sub Department_rngClass_Sub rngClass_Master Sku_rngMsku Desc_First Exception Date_1st Exception_2nd Exception_3rd Exception_4th Exception_5th Exception_6th Exception","_")