In general I have a good macro for change management for a single value and now can write one for an multi dimensional array but need to be able to differential between without the use of error handling.
Is there any other work around for when the target is only one cell? the error handling below handles the issue but I consider it to be "sloppy."
Suggestions are appreciated on a better method.
Sub Dims(target As Variant)
Dim varData As Variant
Dim i As Integer
Dim j As Integer
varData = target
On Error GoTo Err
For i = 1 To UBound(varData, 1)
For j = 1 To UBound(varData, 2)
Debug.Print i, j, varData(i, j)
Next j
Next i
Err:
If Err.Number = 13 Then
Debug.Print target.Value
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Err.Number & " just occured."
ElseIf Err.Number <> 13 And Err.Number <> 0 Then
Debug.Print "Err No.= "; Err.Number
Else
Debug.Print "No Error"
End If
End Sub
I set up a if then statement to run one way if target.count =1 and another if target.count>1
Related
Why does Join() need a double transposition of a 1-dim Long array?
Due to MS Help
the Join() function requires a sourcearray as "one-dimensional array containing substrings to be joined" (btw the help site makes no difference whether it is a Variant or Long).
Note: In the VBE glossary
an array is defined as set of sequentially indexed elements having the same intrinsic data type.
It's no problem to connect 1-dim Variant arrays via Join() and
it's even possible to join numbers as well as they seem to be internally interpreted as "convert us to strings".
Issue with a 1-dim array declared as Long
In some cases I want to restrict the elements type to Long and avoid the Variant solution mentioned above. -
Declaring a "flat" array - here: Numbers() - as Long, however raises Error 5 "Invalid procedure call or argument",
if you try to connect results via a simple
'[2] Failing
Join(Numbers, "|") .
I found an interesting ► work around via a basically redundant double transposition (c.f. [1]),
as it "converts" a flat 1-dim array eventually back to the same dimension.
'[1] work around
Join(Application.Transpose(Application.Transpose(Numbers)), "|")
Question
What's the internal difference how VBA treats both cases and why does Join() need a double transposition of a 1-dim Long array here?
Example call to join a "flat" array declared as Long
In order to show the workaround code line [1] as well as the error raising code line [2],
I integrated a basic error handling showing user defined error lines (ERL), too.
VB Editor's immediate window shows Error 5 in ERL 200:
OK: [1] 3 elems: ~> 100|200|300
ERL: 200 Error No 5 Invalid procedure call or argument
Example call
Sub JoinArr()
Dim Numbers() As Long ' provide for long array Numbers()
FillNumbers 3, Numbers ' call sub procedure to assign 3 numbers to array Nums
' Numbers is now an array of 3 numbers
On Error GoTo oops
'[1] work around - why does Join() need a double transposition in a 1-dim array?
100 Debug.Print " OK: [1] " & UBound(Numbers) & " elems:" & _
" ~> " & Join(Application.Transpose(Application.Transpose(Numbers)), "|")
'[2] join an already existing "flat" array raises Error 5 "Invalid procedure call or argument"
200 Debug.Print " OK [2] " & UBound(Numbers) & " elems:" & _
" ~> " & Join(Numbers, "|")
Exit Sub
oops: Debug.Print "ERL: " & Erl & " Error No " & Err.Number & " " & Err.Description
End Sub
Sub FillNumbers called by above main procedure
Sub FillNumbers(ByVal n As Long, arr)
ReDim arr(1 To n)
arr(1) = 100
arr(2) = 200
arr(3) = 300
End Sub
Trying to Join() an array of Longs will fail:
Sub JoinTestFails()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
With Application.WorksheetFunction
msg = Join(Numbers, "|")
End With
MsgBox msg
End Sub
The double use of TRANSPOSE() gets around this by generating a one-dimensional, one-based array of Variants:
Sub JoinTest()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
With Application.WorksheetFunction
Arr = .Transpose(.Transpose(Numbers))
msg = LBound(Arr) & "**" & UBound(Arr) & vbCrLf
msg = msg & Join(.Transpose(.Transpose(Numbers)), "|") & vbCrLf & TypeName(Arr)
End With
MsgBox msg
End Sub
To me, this use of TRANSPOSE is non-intuitive. I would rather make the Variant array with:
Public Function MkVar(arr() As Long) As Variant
' make a variant array from a long array
Dim temp() As Variant, i As Long
ReDim temp(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
temp(i) = arr(i)
Next i
MkVar = temp
End Function
and then:
Sub JoinTest2()
Dim Numbers(0 To 2) As Long, msg As String
Numbers(0) = 0
Numbers(1) = 1
Numbers(2) = 2
arr = MkVar(Numbers)
msg = LBound(arr) & "**" & UBound(arr) & vbCrLf
msg = msg & Join(MkVar(Numbers), "|") & vbCrLf & TypeName(arr)
MsgBox msg
End Sub
I am a VBA novice and I am trying to print an array that I was able to make (basically copying from another post) in VBA today. I placed a break into the script and inspected the array in the locals page to see that the array captures what I want (and some extra data that I will filter out). I spent the day reading about printing arrays on stack overflow and other sites and I ended up a bit lost. My goal is to export the array as a table in excel.
The script looks for underlined sentences in a 400 page word document and places them into the array. All that's really necessary for printing is the underlined sentences, so maybe an array wasn't the best approach? How can I export the array 'myWords' to a fresh excel document or one that I designate?
Many thanks for your help!
Sub addUnderlinedWordsToArray()
On Error GoTo errhand:
Dim myWords() As String
Dim i As Long
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content
Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Application.ScreenUpdating = False
ReDim myWords(aRange.Words.Count) ' set a array as large as the
' number of words in the doc
For Each Sentence In ActiveDocument.StoryRanges
For Each w In ActiveDocument.Sentences
If w.Font.Underline <> wdUnderlineNone Then
myWords(ArrayCounter) = w
ArrayCounter = ArrayCounter + 1
End If
Next
Next
Set myDoc = Nothing
Set aRange = Nothing
Set sRange = Nothing
Application.ScreenUpdating = True
Exit Sub
errhand:
Application.ScreenUpdating = True
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End Sub
I prefer to use Late Binding over adding an external reference to Excel. This will allow the code to work properly no mater what version of Office is installed.
Sub addUnderlinedWordsToArray()
On Error GoTo errhand:
Dim myWords() As String
Dim i As Long
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content
Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Application.ScreenUpdating = False
ReDim myWords(aRange.Words.Count) ' set a array as large as the
' number of words in the doc
For Each Sentence In ActiveDocument.StoryRanges
For Each w In ActiveDocument.Sentences
If w.Font.Underline <> wdUnderlineNone Then
myWords(ArrayCounter) = w
ArrayCounter = ArrayCounter + 1
End If
Next
Next
ReDim Preserve myWords(ArrayCounter - 1)
AddWordsToExcel myWords
Set myDoc = Nothing
Set aRange = Nothing
Set sRange = Nothing
Application.ScreenUpdating = True
Exit Sub
errhand:
Application.ScreenUpdating = True
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End Sub
Sub AddWordsToExcel(myWords() As String)
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Dim wb As Object
Set wb = xlApp.Workbooks.Add
wb.Worksheets(1).Range("A1").Resize(UBound(myWords) + 1).Value = xlApp.Transpose(myWords)
xlApp.Visible = True
End Sub
This is tested and working fine :
Option Explicit
Sub addUnderlinedWordsToArray()
Dim myWords() As String
Dim i As Long
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content
Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Dim Ex0 As Excel.Application
Dim Wb0 As Workbook
Application.ScreenUpdating = False
On Error GoTo errhand:
For Each Sentence In ActiveDocument.StoryRanges
For Each w In ActiveDocument.Sentences
If w.Font.Underline <> wdUnderlineNone Then
ReDim Preserve myWords(ArrayCounter)
myWords(ArrayCounter) = w
ArrayCounter = ArrayCounter + 1
End If
Next
Next
On Error GoTo 0
Set myDoc = Nothing
Set aRange = Nothing
Set sRanges = Nothing
Set Ex0 = New Excel.Application
Set Wb0 = Ex0.workbooks.Add
Ex0.Visible = True
Wb0.Sheets(1).Range("A1").Resize(UBound(myWords) + 1, 1) = WorksheetFunction.Transpose(myWords)
Application.ScreenUpdating = True
Debug.Print UBound(myWords())
Exit Sub
errhand:
Application.ScreenUpdating = True
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End Sub
Make sure to have the Microsoft Excel 14.0 Object Library ticked in Tools/References
The code provided in the question has some problems, which I've tried to correct as per the problem description.
The code declares a number of object variables, assigning them in the same line as the declaration, but these objects are never used. In order to improve code readability and make these objects "obvious" I've moved the instantiations to new lines.
The sample code below then substitutes these objects for the ActiveDocument... objects used in the original code, where these objects are intended to be used. This makes the code more readabile and more efficient.
The use of StoryRanges is questionable in the context of the code. StoryRanges are not the same as Sentences. On the assumption that the use of StoryRanges was a misunderstanding or typo, I've changed the code to use Sentences. If StoryRanges is meant, the code can loop through them, but certain structural changes would be required. (StoryRanges enables code to access all parts of a document such as TextBoxes, Headers, Footers, Endnotes - instead of just the main body of the document.)
It makes no sense to loop sentences while sizing the array to the number of words in the document. This has been changed to the number of sentences, which will require less memory.
Only the text, not the entire sentence Range should be added to the array since Excel can't do anything with a Word.Range except accept its text. This will require less memory.
On the assumption that not every sentence in the document is underlined, it's not necessary to maintain an array with empty members, so after the loop the array is resized to contain only those that have been populated. (ReDim Preserve myWords(ArrayCounter - 1)). This will avoid writing "empty" content to the Excel worksheet.
The code to write to Excel is in a separate procedure, making it re-usable for other arrays that might need to be transferred to Excel. The code has been written as late-binding, making it independent of requiring a reference to the Excel library. If early-binding (with a reference) is desired, those declarations are commented out in-line.
The writing to Excel only occurs if the array contains members. If ArrayCounter has never been incremented, the call to the other procedure is not performed.
The Excel objects are set to Nothing at the end of that procedure.
Note: The code posted in the question and used here picks up any sentence that contains an underline.
Sample code:
Sub addUnderlinedWordsToArray()
On Error GoTo errhand:
Dim myWords() As String
Dim i As Long
Dim myDoc As Document
Dim aRange As Range
Dim sRanges As Sentences
Dim ArrayCounter As Long ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Application.ScreenUpdating = False
Set myDoc = ActiveDocument ' Change as needed
Set aRange = myDoc.content
Set sRanges = myDoc.Sentences
ArrayCounter = 0
ReDim myWords(aRange.Sentences.Count - 1) ' set a array as large as the
' number of sentences in the doc
For Each Sentence In sRanges
If Sentence.Font.Underline <> wdUnderlineNone Then
myWords(ArrayCounter) = Sentence.text
ArrayCounter = ArrayCounter + 1
End If
Next
If ArrayCounter > 0 Then
ReDim Preserve myWords(ArrayCounter - 1)
WriteToExcel myWords
End If
Set myDoc = Nothing
Set aRange = Nothing
Set sRanges = Nothing
Application.ScreenUpdating = True
Exit Sub
errhand:
Application.ScreenUpdating = True
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
End Sub
Sub WriteToExcel(a As Variant)
Dim appExcel As Object 'Excel.Application
Dim wb As Object ' Excel.Workbook
Dim r As Object ' Excel.Range
Dim i As Long
Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = True
appExcel.UserControl = True
Set wb = appExcel.Workbooks.Add
Set r = wb.Worksheets(1).Range("A1")
r.Resize(UBound(myWords) + 1).Value = xlApp.Transpose(myWords)
Set r = Nothing
Set wb = Nothing
Set appExcel = Nothing
End Sub
The general answer is to use Range ("A1") = myWords(ArrayCounter)
You would need to step through the array while simultaneously moving to the next cell.
You could also use Range ("A1:B3") = myWords.
I don't understand why the code bellow is executed when the value of
strArray(0) is Subscript out of range. My booleanVariable changes to true and I don't want that.
If Left(strArray(0), 3) = "Usu" Then
booleanVariable = True
End If
Make sure the array(0) is not empty before trying to do string manipulation
sub t
If Initialized(strArray) Then ' is array setup
If strArray(0) <> "" Then ' if array has value
If Left(strArray(0), 3) = "Usu" Then
booleanVariable = True
End If
Else
MsgBox "No value in array"
End If
Else
MsgBox "Array not setup"
End If
end sub
Function Initialized(val) As Boolean
On Error GoTo errHandler
Dim i
If Not IsArray(val) Then GoTo exitRoutine
i = UBound(val)
Initialized = True
exitRoutine:
Exit Function
errHandler:
Select Case Err.Number
Case 9 'Subscript out of range
GoTo exitRoutine
Case Else
Debug.Print Err.Number & ": " & Err.Description, _
"Error in Initialized()"
End Select
Debug.Assert False
Resume
End Function
I have a module in a worksheet that is supposed to pass an array to another sub in the same module. So far, I've noticed that the variable N which is being used to to pull each individual array element always says 0 in the watch window, how do I get my elements out of the array? Here is the code:
Option Explicit
Sub CreateReports()
Dim numRows As Integer
Dim numCount As Integer
Dim category As String
Dim size As Integer
Dim sizeCount As Integer
Dim departmentNums() As Integer
With Sheets("GM Alignment")
numRows = Application.WorksheetFunction.CountA(Range("A2:A1048576"))
.Range("A2").Select
Do While numCount < numRows
category = ActiveCell.Value
size = Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 1).End(xlToRight)).Columns.Count - 1
If size > 7 Then
size = 0
End If
ReDim departmentNums(size)
.Cells(ActiveCell.Row, 1).Select
For sizeCount = 0 To size
ActiveCell.Offset(0, 1).Select
departmentNums(sizeCount) = ActiveCell.Value
Next sizeCount
.Cells(ActiveCell.Row, 1).Select
GenerateReports Arr:=departmentNums, Sheet:=category
ActiveCell.Offset(1, 0).Select
numCount = numCount + 1
Loop
End With
End Sub
Sub GenerateReports(ByRef Arr() As Integer, Sheet As String)
Dim N As Integer
For N = LBound(Arr) To UBound(Arr)
Dim Lastrow As Long
With Sheets("DATA")
If .Range("I:I").Find(N, , xlValues, xlWhole, , , False) Is Nothing Then
MsgBox "No " + Sheet + " rows found. ", , "No Rows Copied": Exit Sub
Else
Application.ScreenUpdating = False
Lastrow = .Range("K" & Rows.Count).End(xlUp).Row
.Range("K1:K" & Lastrow).AutoFilter Field:=1, Criteria1:=N
.Range("K2:K" & Lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets(Sheet).Range("A2").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
.AutoFilterMode = False
'Position on cell A3
With Application
.CutCopyMode = False
.Goto Sheets("DATA").Range("A2")
.ScreenUpdating = True
End With
MsgBox "All matching data has been copied.", , "Copy Complete"
End If
End With
Next N
End Sub
Thanks!
Not really looking too far into your code but I noticed that at no point do you read from or assign to Arr in GenerateReports. I believe you are misunderstanding how Arrays behave.
Dim index as Integer
For index = LBound(Arr) To UBound(Arr)
Debug.Print "Index: "; index; " Value: " Arr(index)
Next N
LBound(Arr) and Ubound(Arr) return the lowest and highest index of Arr not the values. In order to access the values contained in Arr use Arr(index).
If you don't care about the index you can use
Dim element as Integer
For each element in Arr
debug.Print element
Next n
It is recommended to use this method whenever possible, as it allows for other sequence's to be used such as Collection. However, it is not always possible such as when you are iterating over multiple sequences or parts of a sequence.
Here is a basic example:
Sub PrintOneToTen()
Dim xs(1 to 10) as Integer
FillArray xs
Dim x as Integer
For Each x In xs
Debug.Print x
Next x
' or just Debug.Print Join(xs, vbNewLine)
End Sub
Sub FillArray(ByRef xs() As Integer)
Dim i as Integer
For i = LBound(xs) To Ubound(xs)
xs(i) = i
Next i
End Sub
Documentation for VB.NET Arrays is listed here. Note VB.NET is not VBA, but as far as arrays are concerned 99% of the info there should be the same in VBA. I would post the VBA documentation but it's buried deep in Microsofts' database and I don't believe they care about it.
I have an array that is populated if a formula produces an "X" in a cell that is part of a range:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Fault(10) As Boolean
For i = 1 To 10
If Range("A" & i).Value = "X" Then
Fault(i) = True
End If
Next i
MsgBox Fault 'VBA Errors Here With "Type Mismatch"
End Sub
My question is, is it possible to return an entire array as a string. So in the above example, I want the message box to return "0000000000" if there were no faults. If there was a fault in the 7th array, then it would return "0000001000".
My aim is to check that the string is always equal to "0000000000" in order to proceed. However, if there's a better way of checking if the entire array is false then that would be much easier.
Try this:
Sub JoinArray()
Dim Fault(9) As String, arrString As String
For i = 1 To 10
If Range("A" & i) = "X" Then
Fault(i - 1) = 1
Else
Fault(i - 1) = 0
End If
Next i
arrString = Join(Fault(), "")
If InStr(arrString, "1") Then
MsgBox "Fault Found"
Else
MsgBox "No faults found"
End If
End Sub
Notes:
Typically an array is zero indexed so Fault(9) allows for 10 slots e.g. Range("A1:A10")
The "" argument of Join means there are no space in the output i.e. 0011000000
Alternative method without using an array
Sub FindFaults()
Dim rng As Range, cl As Range, faultLocations As String
Set rng = Range("A1:A1000")
faultLocations = "Faults found in the following cell(s):" & vbCrLf & vbCrLf
If WorksheetFunction.CountIf(rng, "X") = 0 Then
MsgBox "No Fault Found"
Else
For Each cl In rng
If cl = "X" Then
faultLocations = faultLocations + "Cell: " & cl.Address & vbCrLf
End If
Next cl
End If
MsgBox faultLocations
End Sub