Would like to include a value to all my cells in column G if there are blank in column K, else no change.
If ActiveSheet.Range("K").Value, Criteria1:=" = " Then ActiveSheet.Range("G").Value = "Promo"
Else
Exit Sub
In order to test all the values you need to loop through the column. My example assumes the data doesn't have more than 100'000 lines and that you were testing for " = " to be included... addapt as needed.
Sub TestColumnK()
For i = 1 To ActiveSheet.Range("K100000").End(xlUp).Row
If InStr(1, ActiveSheet.Range("K" & i).Value, "=") > 0 Then
ActiveSheet.Range("G" & i).Value = "Promo"
End If
Next i
End Sub
For Each cell In rng
workSheetName = Format(SaturdayIsComing(), "mm-dd-yyyy") & " " & cell.Value
If WorksheetExists(workSheetName) Then
Dim localRange, localCell As Range
Set localRange = Worksheets(workSheetName).Range("D8:D19")
Dim contents As Variant
contents = ""
Dim firstLine As Boolean
firstLine = True
For Each localCell In localRange
If Len(localCell.Value) > 0 Then
If firstLine Then
contents = contents & localCell.Value & Chr(11)
Else
contents = contents & Chr(9) & Chr(9) & Chr(9) & localCell.Value & Chr(11)
End If
Else
contents = fixString(contents)
End If
If Len(contents) > 0 Then
firstLine = False
End If
Next localCell
For Each cc In wDoc.SelectContentControlsByTag(cell.Value & "Notes")
If Len(contents) > 0 Then
cc.Range.Text = fixString(contents)
Else
cc.Range.Text = "No Issues Found"
End If
Next
Else
errorCodesString = errorCodesString & cell.Value & ":"
End If
Next cell
Output to Word
Forgot to terminate the meeting
This is a test message\'s
If my cell contains a ' then I get an error saying
One of the values passwed to this method or property is incorrect
I know a ' is a comment in VBA. How do I go around this while preserving the notes that someone had added to the Excel cell?
You need to write a piece of code to search for quotes, either the single (') or double (") variety and either add a backslash before them OR double the character so '' in place of ' and "" in place of " and run this on contents before assigning it to cc.Range.Text.
This routine can also check for other instances of incorrect strings and fix them.
Something like this would do:
Function fixString(ByVal strIn As Variant) As String
Dim i As Integer
Const strIllegals = "\'"""
For i = 1 To Len(strIllegals)
strIn = Replace(strIn, Mid$(strIllegals, i, 1), "\" & Mid$(strIllegals, i, 1))
Next i
fixString = strIn
End Function
Try changing cell.Value to Replace(cell.Value, "'", "")
Or is it contents that has the apostrophe in it? A bit confusing.
Try changing contents to Replace(contents , "'", "")
I have the following code as part of a Job site labor form, which links a full labor call on the "LocLabor" sheet to various single day sign in sheets. This particular code is to add a complete day to the form, and works great, with the exception of these two lines at the bottom:
.Buttons(bnum).ShapeRange.AlternativeText = dayint + 1
.Buttons(bnum + 1).ShapeRange.AlternativeText = dayint + 1
The "scopy", "ecopy", and "brow" variables are used to work out the appropriate lines to copy and paste to the next day. The buttons that are being altered are the newly pasted buttons that were copied within the scopy/ecopy range and are used to add or delete a line from the table they refer to. I need to be able to change the AltText because I am using that as a reference for which day of the labor call they apply to. The "numdays" variable pulls from locsht.Range("L3").Value, which is set to the current number of days on the form prior to running the macro. So it would have a value of 2 when I see the error
Now to the issue - if I have two days existing in the document and I execute the below code, the name of the button changes, but the Alternative Text does not (it remains as "2" or whatever it was prior to copying). Days 4 and up work perfectly though, it is just the transition from day 2 to 3 that I cannot get to work! It also works if I switch out "dayint + 1" to a string, like "banana" for example, but that obviously doesn't help me.
Any ideas would be appreciated.
Option Explicit
Sub add_day()
Dim numdays As String
Dim tbl As TableStyle
Dim newsht As Worksheet
Dim locsht As Worksheet
Dim scopy As Integer
Dim ecopy As Integer
Dim brow As Integer
Dim dayint As Integer
Dim bnum As Integer
Dim tblstart As String
Application.ScreenUpdating = False
'unlock sheet
Worksheets("LocLabor").Unprotect Password:=SuperSecretPW
'set/get variables
Set locsht = Worksheets("LocLabor")
numdays = locsht.Range("L3").Value
dayint = numdays
Worksheets("Labor Sign In Day " & numdays).Copy Before:=Sheets(numdays + 4)
Worksheets("Labor Sign In Day " & numdays & " (2)").Name = "Labor Sign In Day " & numdays + 1
'update number of days on sheet
locsht.Range("L3") = locsht.Range("L3").Value + 1
'rename new sign in sheet
Set newsht = Worksheets("Labor Sign In Day " & numdays + 1)
newsht.Unprotect Password:=SuperSecretPW
'figure out which rows to copy on main sheet
scopy = locsht.ListObjects(dayint).Range.Rows(1).Row - 1
brow = locsht.ListObjects(dayint).Range.Rows.Count
ecopy = scopy + brow
'Copy/paste new day on LocLabor
locsht.Activate
locsht.Rows(scopy & ":" & ecopy).Copy
locsht.Rows(ecopy + 2).Insert Shift:=xlDown
locsht.ListObjects("Tableday" & numdays).Resize Range("A" & scopy + 1 & ":" & "H" & ecopy)
locsht.Range("A" & ecopy + 2 & ":" & "H" & ecopy + 2) = "=IFERROR($A$17+" & numdays & "," & """Enter Load in Date at Top"")"
locsht.Rows(ecopy + 1).EntireRow.Delete
locsht.PageSetup.PrintArea = "$A$1:$H$" & ecopy + (ecopy - scopy + 1)
locsht.HPageBreaks.Add Before:=locsht.Rows(ecopy + 1)
locsht.ListObjects(dayint + 1).Name = "Tableday" & numdays + 1
bnum = (dayint * 2) + 3
tblstart = locsht.ListObjects(dayint + 1).Range.Rows(1).Row + 1
'Enter correct formulas into sign in sheet
With newsht
.ListObjects(1).Name = "signinday" & numdays + 1
.Range("i12") = Left(newsht.Range("i12").Formula, 28) & numdays & Right(newsht.Range("i12").Formula, 48)
.Range("A17") = "=IF(ISBLANK(LocLabor!G" & tblstart & ")=FALSE,LocLabor!G" & tblstart & "&"" ""&LocLabor!F" _
& tblstart & ",IF(ISBLANK(LocLabor!D" & tblstart & ")=TRUE," & """""" & ",LocLabor!D" & tblstart & "))"
.Range("B17") = "=IF(ISBLANK(LocLabor!B" & tblstart & ")=TRUE, """", LocLabor!B" & tblstart & ")"
.Range("G17") = "=IF(ISBLANK(LocLabor!C" & tblstart & ")=TRUE, """", LocLabor!C" & tblstart & ")"
End With
'rename pasted buttons, update alttext
With locsht
.Buttons(bnum).Name = "Button " & bnum
.Buttons(bnum + 1).Name = "Button " & bnum + 1
.Buttons(bnum).ShapeRange.AlternativeText = dayint + 1
.Buttons(bnum + 1).ShapeRange.AlternativeText = dayint + 1
End With
'lock down sheets
Worksheets("LocLabor").Protect Password:=SuperSecretPW, DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
Worksheets("LocLabor").EnableSelection = xlUnlockedCells
Worksheets("Labor Sign In Day " & numdays + 1).Protect Password:=SuperSecretPW, DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
Worksheets("Labor Sign In Day " & numdays + 1).EnableSelection = xlUnlockedCells
ActiveSheet.Buttons(Application.Caller).TopLeftCell.Offset(3, 0).Select
Application.ScreenUpdating = True
End Sub
I'm working on a project and I'm wondering how I would go about parsing a line like this:
oDesign.ChangeProperty Array("NAME:AllTabs", Array("NAME:LocalVariableTab", Array("NAME:PropServers", "LocalVariables"), Array("NAME:NewProps", Array("NAME:antipad", "PropType:=", "VariableProp", "UserDef:=", true, "Value:=", "40mil")), Array("NAME:ChangedProps", Array("NAME:antipad", "Hidden:=", false))))
into something like this:
oDesign.ChangeProperty(
[
"NAME:AllTabs",
[
"NAME:LocalVariableTab",
[
"NAME:PropServers",
"LocalVariables"
],
[
"NAME:NewProps",
[
"NAME:antipad",
"PropType:=" , "VariableProp",
"UserDef:=" , True,
"Value:=" , "40mil"
]
],
[
"NAME:ChangedProps",
[
"NAME:antipad",
"Hidden:=" , False,
"Value:=" , "40mil"
]
]
]
])
I was thinking about using dictionaries, but I'm not sure how to do this with VBA.
Also, suggestions about indentation are appreciated. I was thinking about using stacks, but I'm sure there are easier ways to do it.
If the goal is to get JSON from this kind of VBA arrays, then this could be a approach:
Sub test()
arr = Array("NAME:AllTabs", Array("NAME:LocalVariableTab", Array("NAME:PropServers", "LocalVariables"), Array("NAME:NewProps", Array("NAME:antipad", "PropType:=", "VariableProp", "UserDef:=", True, "Value:=", "40mil")), Array("NAME:ChangedProps", Array("NAME:antipad", "Hidden:=", False))))
sJSON = "[" & recursiveVBAArrayToJSON(arr, "") & vbLf & "]"
MsgBox sJSON
End Sub
Function recursiveVBAArrayToJSON(arr As Variant, res As String) As String
For i = LBound(arr) To UBound(arr)
If TypeName(arr(i)) = "Variant()" Then
res = res & vbLf & "["
res = recursiveVBAArrayToJSON(arr(i), res)
res = res & vbLf & "]" & IIf(i <> UBound(arr), ",", "")
Else
res = res & vbLf & """" & arr(i) & """" & IIf(i <> UBound(arr), ",", "")
End If
Next
recursiveVBAArrayToJSON = res
End Function
Axel created his solution faster than I created mine and I do not normally post rival solutions unless I think earlier solutions are faulty. Axel's solution does not look faulty but he has not handled indenting (which you specifically mention as important) nor does he concatenate "Xxxx=" with the value. I also think Axel is correct to use recursion rather than collections. However, I decided to post this answer as a possibly interesting alternative.
You can do little with Excel VBA without using the inbuilt collections. However, I rarely have user collections or dictionaries because I do not normally tackle problems big enough to need them in VBA. This requirement looked simple so I thought I would treat it as a training exercise.
My understanding of dictionaries is that a key is compulsory. There are no obvious keys so I have used collections.
The code below is basic. I have performed the minimum of validation and I am sure I could have handled the output in a more elegant manner. I have limited myself to “can it be done?”
I have placed your string in cell A1 of worksheet “Sheet1” as the easiest way of making it available to the macros.
My output does not include the trailing “"Value:=" , "40mil"” because it is not in the input string.
I have handled indenting consistently and I have used a constant so you can easily change the number of spaces. The number of spaces between strings and comma does not seem consistent in your required output so I have made little attempt to match it. However, I see that as a minor detail; the answer to you question is “Yes, your string can be parsed and converted to the output you desire.”
Option Explicit
Enum EVT
DCP
ArrayOpen
ArrayClose
Comma
Str
BoolTrue
BoolFalse
End Enum
Sub Control()
Dim InxOutput As Long
Dim InxToken As Long
Dim Output As New Collection
Dim StrToParse As String
Dim Tokens As New Collection
StrToParse = Worksheets("Sheet1").Cells(1, 1).Value
Call Parse(StrToParse, Tokens)
For InxToken = 1 To Tokens.Count
Debug.Print Tokens.Item(InxToken)
Next
Call CreateOutput(Tokens, Output)
For InxOutput = 1 To Output.Count
Debug.Print Output.Item(InxOutput)
Next
Set Tokens = Nothing
Set Output = Nothing
End Sub
Sub Parse(ByVal Str As String, ByRef Tokens As Collection)
' Str is a string such as: oDesign.ChangeProperty Array("NAME:AllTabs", ...
' On entry, Token must be an empty collection.
' The routine parses Str and creates tokens in Tokens of the form:
' nn¬mm¬xxxxx
' where:
' * nn is the level of the token. 1 for the outer token, oDesign.ChangeProperty,
' and 2, 3 and so on for each nested array or array element
' * ¬ is a separator
' * mm is a enumerator defined by Enum EVT:
' * Enum Indicated token
' * DCP oDesign.ChangeProperty
' * ArrayOpen Array(
' * ArrayClose )
' * Comma ,
' * Str Quoted string
' * BoolTrue true
' * BoolFalse false
' * xxxxx with its preceding ¬ is only present for a quoted string. The value
' of xxxxx is the quoted string without the quotes.
Dim LevelCrnt As Long
Dim PosStrCrnt As Long
Dim PosStrQuote As Long
PosStrCrnt = 1
LevelCrnt = 1
If Mid(Str, PosStrCrnt, 22) <> "oDesign.ChangeProperty" Then
Debug.Assert False
' String does not start as expected
Exit Sub
End If
Tokens.Add LevelCrnt & "¬" & EVT.DCP
LevelCrnt = LevelCrnt + 1
PosStrCrnt = PosStrCrnt + 22
Do While PosStrCrnt < Len(Str)
If Mid(Str, PosStrCrnt, 1) = " " Then
' Step over space
PosStrCrnt = PosStrCrnt + 1
ElseIf Mid(Str, PosStrCrnt, 1) = "," Then
' Comma
Tokens.Add LevelCrnt & "¬" & EVT.Comma
PosStrCrnt = PosStrCrnt + 1
ElseIf Mid(Str, PosStrCrnt, 1) = ")" Then
' End of array
LevelCrnt = LevelCrnt - 1
Tokens.Add LevelCrnt & "¬" & EVT.ArrayClose
PosStrCrnt = PosStrCrnt + 1
ElseIf Mid(Str, PosStrCrnt, 6) = "Array(" Then
' Start of array
Tokens.Add LevelCrnt & "¬" & EVT.ArrayOpen
LevelCrnt = LevelCrnt + 1
PosStrCrnt = PosStrCrnt + 6
ElseIf Mid(Str, PosStrCrnt, 1) = """" Then
' Quoted string
PosStrCrnt = PosStrCrnt + 1
PosStrQuote = InStr(PosStrCrnt, Str, """")
If PosStrQuote = 0 Then
' Unterminated string
Debug.Assert False
Exit Sub
End If
Tokens.Add LevelCrnt & "¬" & EVT.Str & "¬" & Mid(Str, PosStrCrnt, PosStrQuote - PosStrCrnt)
PosStrCrnt = PosStrQuote + 1
ElseIf Mid(Str, PosStrCrnt, 4) = "true" Then
Tokens.Add LevelCrnt & "¬" & EVT.BoolTrue
PosStrCrnt = PosStrCrnt + 4
ElseIf Mid(Str, PosStrCrnt, 5) = "false" Then
Tokens.Add LevelCrnt & "¬" & EVT.BoolFalse
PosStrCrnt = PosStrCrnt + 5
Else
' Unexpected token
Debug.Print PosStrCrnt & ": " & Mid(Str, PosStrCrnt, 20)
Debug.Assert False
Exit Sub
End If
Loop
End Sub
Sub CreateOutput(ByRef Tokens As Collection, ByRef Output As Collection)
' Tokens is a collection of tokens created by Parse
' On entry. Output is an empty collection
' On exit, Output is an human readable version of Tokens
' The routine processes the contents in sequence.
Dim ContinuePending As Boolean
Dim EVTCrnt As Long
Dim InxToken As Long
Dim InxPart As Long
Dim LevelCrnt As Long
Dim Part() As String
Dim Pending As String
Const SpacesPerLevel As Long = 4
Pending = ""
ContinuePending = False
For InxToken = 1 To Tokens.Count
' Split token into components
Part = Split(Tokens.Item(InxToken), "¬")
LevelCrnt = Val(Part(0))
EVTCrnt = Val(Part(1))
Select Case EVTCrnt
Case EVT.DCP
Debug.Assert LevelCrnt = 1
' No indent for level 1
Output.Add ("oDesign.ChangeProperty(")
Case EVT.ArrayOpen
' Ouput [ in line with array's parent
Output.Add (Space((LevelCrnt - 2) * SpacesPerLevel) & "[")
Case EVT.ArrayClose
If Pending <> "" Then
' The final contents of this array have not been output
Output.Add (Space((LevelCrnt - 1) * SpacesPerLevel) & Pending)
Pending = ""
End If
' Ouput ] or ]) in line with array's parent
If InxToken = Tokens.Count Then
' This is the close of the final array. Include closing bracket
Output.Add ("])")
Else
' This may be a nested array with a following comma
Pending = "]"
End If
Case EVT.Comma
' Add to Pending
Pending = Pending & ","
If Not ContinuePending Then
' The next string is not to be added to Pending so output
Output.Add (Space((LevelCrnt - 2) * SpacesPerLevel) & Pending)
Pending = ""
End If
Case EVT.Str
If Pending <> "" Then
' This string is to be appended to previous token
Pending = Pending & " """ & Part(2) & """"
Else
' This is a new string
Pending = """" & Part(2) & """"
End If
If Right(Part(2), 2) = ":=" Then
' The next string is to be appended to this one
ContinuePending = True
' Add some spaces before comma
Pending = Pending & " "
Else
ContinuePending = False
' Don't output in case comma is to be appended
End If
Case BoolTrue
If Pending <> "" Then
' This string is to be appended to previous token
Pending = Pending & " ""True"""
Else
' This is a new string
Pending = """True"""
End If
' True cannot be continued but there may be a following comma
ContinuePending = False
Case BoolFalse
If Pending <> "" Then
' This string is to be appended to previous token
Pending = Pending & " ""False"""
Else
' This is a new string
Pending = """False"""
End If
' False cannot be continued but there may be a following comma
ContinuePending = False
End Select
Next
If Pending <> "" Then
' Final output
Output.Add Pending
Pending = ""
End If
End Sub
I'm having some trouble understanding some strange behavior. The .address property of the range class is returning a cell in "Cell:Cell" format. Both (1) and (2) give the address in the form of "$A$1:$A$1" instead of simply "$A$1". A snippet of code is listed below:
With Sheet1
Set r = .Range("MyRange")
'(1)*
Debug.Print r.Address
r.Formula = "= 1 + 1"
For i = 1 To 47
Set r = r.Offset(0, 1)
'above
r1 = r.Offset(-1, 0).Address(True, False)
'above to the left
r2 = r.Offset(-1, -1).Address(True, False)
'to the left
r3 = r.Offset(0, -1).Address(False, False)
'(2)*
Debug.Print r.Address & "gets: " & r1 & "+" & r2 & "+" r3
Next
End With
Debug.Print in either case prints in the format:
"$D$10:$D$10 gets: $D$9:$D$9 + $C$8:$C$8 + ... " and so on.
Note:
I'm not saying that (1) and (2) print the same thing.. they both print as expected, it's just the format of what is printed is repeated twice as a range of one cell.
Any thoughts would be greatly appreciated - B
EDIT: When I save and close out of the workbook, the behavior stops and it returns to printing addresses as expected "$D$10 gets: ... "
Please try the following:
Sub dural()
Dim r As Range
Set r = Range("A1")
s = r.Address
s = s & vbCrLf & r.Address(1, 1)
s = s & vbCrLf & r.Address(1, 0)
s = s & vbCrLf & r.Address(0, 1)
s = s & vbCrLf & r.Address(0, 0)
MsgBox s
End Sub
You should see no colons.