This code is designed to detect the columns of start and finish of a shape which is used and displayed onto the caption of the shape itself. The following code is the problematic code:
Sub Take_Baseline()
Dim forcast_weeksStart() As String
Dim forcast_weeksEnd() As String
Dim forcastDate As String
Dim shp As Shape
Dim split_text() As String
'cycle through all the shapes in the worsheet and enter the forcast date for all the projects into their respective boxes
For Each shp In ActiveSheet.Shapes
'initialize forcast date by parsing
forcast_weeksStart = Split(shp.TopLeftCell.Column.Text, " ")
forcast_weeksEnd = Split(shp.BottomRightCell.Column.Text, " ")
forcastDate = forcast_weeksStart(1) & "-" & forcast_weeksEnd(1)
temp = shp.OLEFormat.Object.Object.Caption
If InStr(temp, "/-/") > 0 & InStr(temp, "In Prog") Then
split_text = Split(shp.OLEFormat.Object.Caption, " ")
For i = 0 To (i = 3)
shp.TextFrame.Characters.Caption = split_text(i) & vbNewLine
Next i
ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption = ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption & vbNewLine & ActiveSheet.Cells(4, AShape.TopLeftCell.Column).Text & " - " & ActiveSheet.Cells(4, AShape.BottomRightCell.Column).Text & vbNewLine & "dates: " & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & "/" & "actualDate"
' ElseIf InStr(temp, "/-/") > 0 & InStr(temp, "In Prog") = 0 Then
'split_text = Split(shp.OLEFormat.Object.Object.Caption, " ")
' For i = 0 To (i = 2)
' shp.OLEFormat.Object.Caption = split_text(i) & vbNewLine
' Next i
'ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption = ActiveSheet.Shapes(Sheet4.Range("B1")).TextFrame.Characters.Caption & vbNewLine & "In Prog" & vbNewLine & ActiveSheet.Cells(4, AShape.TopLeftCell.Column).Text & " - " & ActiveSheet.Cells(4, AShape.BottomRightCell.Column).Text & vbNewLine & "dates: " & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & forcast_weeksStart(1) & " - " & forcast_weeksEnd(1) & "/" & "actualDate"
End If
Next shp
'For testing purposes
Sheet4.Range("A20").Value = forcast_weeksStart(1)
Sheet4.Range("A21").Value = forcast_weeksEnd(1) End Sub
The error is an
"invalid qualifier"
message which occurs on line
forcast_weeksStart = Split(shp.TopLeftCell.Column.Text, " ")
Right on the "column" word. I don't get why this is happening since the actual drop down menu has the column operation which i can select. I have tried everything from changing it to the OLEformat.Object.Caption etc etc. But nothing has worked. I am still relatively new to vba so any help will be appreciated. Thanks
I have a Form in VBA that has a button that will create a new sheet within the workbook.
On that new sheet, I need 4 buttons to be on there with their code already in place.
When I hit the 'create new sheet' button, I have the following code for updating the new buttons on the new sheet:
'Update quantity button
ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
, DisplayAsIcon:=False, Left:=150, Top:=20, Width:=123.75, Height _
:=23.25).Select
ActiveSheet.OLEObjects(1).Object.Caption = "Update Quantity"
'update quantity code
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Private Sub CommandButton1_Click()" & vbLf & _
"Dim ComponentAmt As Double" & vbLf & _
"ComponentNum = Application.InputBox(""Please provide a component number"", ""Component Number"", Type:=1)" & vbLf & _
"ComponentAmt = Application.InputBox(""Quantity received of the component"", ""Quantity Received"", Type:=1)" & vbLf & _
"Set found = Range(""A:A"").Find(what:=ComponentNum, LookIn:=xlValues, LookAt:=xlWhole)" & vbLf & _
"If found Is Nothing Then" & vbLf & _
"MsgBox ""Your component number was not found" & vbLf & _
"Else" & vbLf & _
"found.Offset(0, 2).Value = found.Offset(0,2).Value + ComponentAmt" & vbLf & _
"End If" & vbLf & _
"End Sub"
End With
'Archive button
ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
, DisplayAsIcon:=False, Left:=400, Top:=200, Width:=123.75, Height _
:=23.25).Select
ActiveSheet.OLEObjects(2).Object.Caption = "1. Export PO"
'Archive Code
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
LineNum2 = .CountOfLines + 1
.InsertLines LineNum2, _
"Private Sub CommandButton2_Click()" & vbLf & _
"ActiveSheet.Copy" & vbLf & _
"With ActiveSheet.UsedRange" & vbLf & _
".Copy" & vbLf & _
".PasteSpecial xlValue" & vbLf & _
".PasteSpecial xlFormats" & vbLf & _
"End With" & vbLf & _
"Application.CutCopyMode = False" & vbLf & _
"ActiveWorkbook.SaveAs ""Full Path/""" & vbLf & _
"End Sub"
End With
'Hide button
ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
, DisplayAsIcon:=False, Left:=400, Top:=250, Width:=123.75, Height _
:=23.25).Select
ActiveSheet.OLEObjects(3).Object.Caption = "2. Done"
'hide button Code
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
LineNum4 = .CountOfLines + 1
.InsertLines LineNum4, _
"Private Sub CommandButton3_Click()" & vbLf & _
"ActiveSheet.Select" & vbLf & _
"ActiveWindow.SelectedSheets.Visible = False" & vbLf & _
"End Sub"
End With
'View price button
ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _
, DisplayAsIcon:=False, Left:=200, Top:=20, Width:=123.75, Height _
:=23.25).Select
ActiveSheet.OLEObjects(4).Object.Caption = "View Price"
'View price code
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
LineNum4 = .CountOfLines + 1
.InsertLines LineNum4, _
"Private Sub CommandButton4_Click()" & vbLf & _
"Range(""I10"").Select" & vbLf & _
"ActiveCell.FormulaR1C1 = ""=VLOOKUP(R[-8]C[-7],KitList!C[-8]:C[11],17,FALSE)""" & vbLf & _
"Range(""J10"").Select" & vbLf & _
"ActiveCell.FormulaR1C1 = ""=VLOOKUP(R[-8]C[-8],KitList!C[-9]:C[10],18,FALSE)""" & vbLf & _
"Range(""I11"").Select" & vbLf & _
"ActiveCell.FormulaR1C1 = ""=VLOOKUP(R[-9]C[-7],KitList!C[-8]:C[11],19,FALSE)""" & vbLf & _
"Range(""J11"").Select" & vbLf & _
"ActiveCell.FormulaR1C1 = ""=VLOOKUP(R[-9]C[-8],KitList!C[-9]:C[10],20,FALSE)""" & vbLf & _
"End Sub"
End With
The buttons then show on the new worksheet, but when I click on them, nothing happens.
Also, when clicking on the sheet in VBA I have the following code that is supposed to be for the buttons.
Private Sub CommandButton1_Click()
'update quantity
Dim ComponentAmt As Double
ComponentNum = Application.InputBox("Please provide a component number", "Component Number", Type:=1)
ComponentAmt = Application.InputBox("Quantity received of the component", "Quantity Received", Type:=1)
Set found = Range("A:A").Find(what:=ComponentNum, LookIn:=xlValues, LookAt:=xlWhole)
If found Is Nothing Then
MsgBox "Your component number was not found"
Else
found.Offset(0, 2).Value = found.Offset(0, 2).Value + ComponentAmt
End If
End Sub
Private Sub CommandButton2_Click()
'export PO
ActiveSheet.Copy
With ActiveSheet.UsedRange
.Copy
.PasteSpecial xlValue
.PasteSpecial xlFormats
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveAs "Full Path/"
End Sub
Private Sub CommandButton3_Click()
'hides the PO in the document
ActiveSheet.Select
ActiveWindow.SelectedSheets.Visible = False
End Sub
Private Sub CommandButton4_Click()
'view price
Range("I10").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[-8]C[-7],KitList!C[-8]:C[11],17,FALSE)"
Range("J10").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[-8]C[-8],KitList!C[-9]:C[10],18,FALSE)"
Range("I11").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[-9]C[-7],KitList!C[-8]:C[11],19,FALSE)"
Range("J11").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[-9]C[-8],KitList!C[-9]:C[10],20,FALSE)"
End Sub
Should I make the code for each button as a sub then on the buttons call the sub?
If I create more then one new sheet, are the button names going to change?
This is part of a much larger macro that has multiple instances of Application.OnTime that work just fine.
My issue with this one below is in WaitForPriceVolume() when it gets to the For Each loop and the If is true, it doesn't go back to the procedure WaitForPriceVolume(). It circles back to all the procedures that were called before, effectively just doing the Exit Sub as if the OnTime didn't exist.
When I strip out just the below code and add fixed values for the global variables being used, the Application.OnTime works. It's only when I plug it back into the bigger macro.
Sub BDP_PriceVolume()
Dim lsStartRange As String
Dim lsEndRange As String
Dim lnStartRow As Long
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Set sht = Worksheets("Variables")
' Use gvList
lsStartRange = "C" & gnStartRow
lnStartRow = gnStartRow + UBound(gvList, 2)
lsEndRange = "C" & lnStartRow
sht.Range(lsStartRange & ":" & lsEndRange).Value = _
"=BDP($A" & gnStartRow & "&Variables!$A$2,Variables!$D$2)"
lsStartRange = "D" & gnStartRow
lsEndRange = "D" & lnStartRow
If Worksheets("Variables").Cells(3, 3).Value <> "" Then
sht.Range(lsStartRange & ":" & lsEndRange).Value = _
"=BDH($A" & gnStartRow & "&Variables!$A$2,Variables!$E$3" & "," & _
"Variables!$B$4,Variables!$C$3," & _
Chr(34) & "BarTp=T" & Chr(34) & "," & _
Chr(34) & "BarSz=40" & Chr(34) & "," & _
Chr(34) & "Dir=V" & Chr(34) & "," & _
Chr(34) & "Dts=H" & Chr(34) & "," & _
Chr(34) & "Sort=A" & Chr(34) & "," & _
Chr(34) & "Quote=C" & Chr(34) & "," & _
Chr(34) & "UseDPDF=Y" & Chr(34) & ")"
Else
sht.Range(lsStartRange & ":" & lsEndRange).Value = _
"=BDP($A" & gnStartRow & "&Variables!$A$2,Variables!$E$2)"
End If
sht.Range("C" & gnStartRow & ":" & lsEndRange).Select
Application.Run "RefreshCurrentSelection"
Application.OnTime Now + TimeValue("00:00:03"), "WaitForPriceVolume"
End Sub
Private Sub WaitForPriceVolume()
Dim rng As Range
Set rng = sht.Range("C" & gnStartRow & ":D" & fnLastRow(sht, "A"))
Dim cell As Range
Application.ScreenUpdating = True
For Each cell In rng
If cell.Value = "#N/A Requesting Data..." Then
Application.OnTime Now + TimeValue("00:00:03"), "WaitForPriceVolume"
Exit Sub
End If
Next cell
Call DoneWaitForPriceVolume
End Sub
Own stupidity. All the other instances of OnTime came at the end of the code, so the macro had nothing left to do until the OnTime triggered and I forced everything to circle back to the main macro. I hadn't done that in this case. Problem solved. This haunted me for a week
I've been trying to adapt the method shown here: http://support.microsoft.com/kb/246299 so that I can create a command button in word which will save the document and remove itself when clicked. I've been unable to figure out how to change the position of the button from the default of the top left of the first page however. Ideally I'd like the button to be generated at the end of the document and be centre aligned, or otherwise placed at the cursor position.
Any advice would be very much appreciated :)
Thank You.
My VB.NET project code so far:
Dim shp As Word.InlineShape
shp = wrdDoc.Content.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1")
shp.OLEFormat.Object.Caption = "Save To Disk"
shp.Width = "100"
'Add a procedure for the click event of the inlineshape
Dim sCode As String
sCode = "Private Sub " & shp.OLEFormat.Object.Name & "_Click()" & vbCrLf & _
"ActiveDocument.SaveAs(""" & sOutFile & """)" & vbCrLf & _
"On Error GoTo NoSave" & vbCrLf & _
"MsgBox ""Document Saved Successfully""" & vbCrLf & _
"Dim o As Object" & vbCrLf & _
"For Each o In ActiveDocument.InlineShapes" & vbCrLf & _
"If o.OLEFormat.Object.Name = ""CommandButton1"" Then" & vbCrLf & _
"o.Delete" & vbCrLf & _
"End If" & vbCrLf & _
"Next" & vbCrLf & _
"Exit Sub" & vbCrLf & _
"NoSave:" & vbCrLf & _
"MsgBox ""Document Failed To Save""" & vbCrLf & _
"End Sub"
wrdDoc.VBProject.VBComponents("ThisDocument").CodeModule.AddFromString(sCode)
wrdApp.Visible = True
As long as everything else is working just set the shp.left = 250 and shp.top = 1200
etc etc.
Just like in VB when you place a button. For more details on the exact calls you should reference this page: http://msdn.microsoft.com/en-us/library/office/hh965406%28v=office.14%29.aspx
But say to center a button you can set left to be the (doc.width - shape.width)
But word buttons allow for much more complex styling and setup.
I am trying to use VBA in Excel to add conditional formatting to a column of a pivot table. The issue is that whenever the pivot table is refreshed, or a filter is changed, etc. the conditional formatting is lost. My solution was to add a macro to the pivot table update event in the workbook, which works ... kinda. It seems that when I run the code that creates the pivot table and adds the code to handle conditional formatting an error occurs but ONLY when the VBA window is NOT open. If the VBA window is open the code executes normally - despite no code changes or reference changes.
Private Sub setupConditionalFormattingForStatusColumn()
Dim thisSheetModule As vbcomponent
Dim formattingCodeString As String
On Error GoTo conditionalFormattingError
formattingCodeString = _
"Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)" & vbNewLine & _
" With Target.parent.Columns(" & harReportColumn("Status") & ")" & vbNewLine & _
" .FormatConditions.AddIconSetCondition" & vbNewLine & _
" .FormatConditions(.FormatConditions.Count).SetFirstPriority" & vbNewLine & _
vbNewLine & _
" With .FormatConditions(1)" & vbNewLine & _
" .IconSet = ActiveWorkbook.IconSets(xl4TrafficLights)" & vbNewLine & _
" .IconCriteria(1).Icon = xlIconYellowExclamation" & vbNewLine & _
vbNewLine & _
" With .IconCriteria(2) " & vbNewLine & _
" .Type = xlConditionValueNumber" & vbNewLine & _
" .value = -1" & vbNewLine & _
" .Operator = 5" & vbNewLine & _
" .Icon = xlIconGreenCircle" & vbNewLine & _
" End With" & vbNewLine & _
vbNewLine & _
" With .IconCriteria(3)" & vbNewLine & _
" .Type = xlConditionValueNumber" & vbNewLine & _
" .value = 1.05" & vbNewLine & _
" .Operator = 7" & vbNewLine & _
" .Icon = xlIconYellowCircle" & vbNewLine & _
" End With" & vbNewLine
formattingCodeString = formattingCodeString & vbNewLine & _
" With .IconCriteria(4)" & vbNewLine & _
" .Type = xlConditionValueNumber" & vbNewLine & _
" .value = 1.15" & vbNewLine & _
" .Operator = 7" & vbNewLine & _
" .Icon = xlIconRedCircleWithBorder" & vbNewLine & _
" End With" & vbNewLine & _
vbNewLine & _
" .ShowIconOnly = True" & vbNewLine & _
" End With" & vbNewLine & _
vbNewLine & _
" .HorizontalAlignment = xlCenter" & vbNewLine & _
" .VerticalAlignment = xlCenter" & vbNewLine & _
" End With" & vbNewLine & _
"End Sub"
Set thisSheetModule = ThisWorkbook.VBProject.VBComponents(harReportSheet.CodeName)
thisSheetModule.CodeModule.AddFromString formattingCodeString
Exit Sub
conditionalFormattingError:
errorLog.logError "WARNING: An error occured while applying the conditional formatting code for the ""Status"" column."
Err.Clear
Resume Next
End Sub
The line which generates the error is: thisSheetModule.CodeModule.AddFromString formattingCodeString but the error is only generated if the VBA window is closed.
Any ideas?
So I was able to find an answer to this issue. Evidently Excel does not properly initialize the codename property of newly created worksheets when the VBA window is not open (the why here is beyond me) but only when it recompiles. A work-around is to force Excel to recompile prior to any calls to the codename property. The solution which worked for me was to place the following code:
On Error Resume Next
Application.VBE.CommandBars.ActiveMenuBar.FindControl(ID:=578).Execute
On Error GoTo conditionalFormattingError
above the line beginning with Set thisSheetModule = ... . Oddly enough the line of code which forces the recompile also throws an error for me which I was able to safely ignore with the surrounding error handling.
More information can be found here: http://www.office-archive.com/2-excel/d334bf65aeafc392.htm
Hope that helps someone out there. :-)