VBA Public Variable Not Working - MS Word - Counting Characters in a Table - vba

The main VBA procedure counts characters in table cells in a Word document. Since it can count characters different ways:
Count the "Objective" text for the selected table
Count the "Accomplishment" text for the selected table
Count both the Obj and Acc texts in each table (loop), for all tables (another loop)
I created calling procedures for each option above that calls the main procedure. This way I pass variables from the calling Sub to the main Sub. These variables (1) tell the main Sub whether I want to count what is in row 3 (objective) or in row 5 (accomplishment) or both, and (2) feed the If/then lines in the main Sub to make sure the right row is counted. At the time, it seemed elegant, in hindsight - not so much.
Word template below:
There will be text in O1 and the VBA will count it (characters, spaces + paragraphs) and output it in C1, and the C1 fill changes red or green if over/under the character limit. The same for A1 and C2 and so on for any number of following tables.
PROBLEM DESCRIPTION
The VBA was working for the actions above when I had the row/columns hard coded into various places in the code. If rows/columns were ever added/deleted from the tables, they would have to updated in multiple spots. It would be simpler if the row/column numbers were in one place and referred back to as variables, so I changed the row/col #s to public variables. Then the problem began.
In the code, I track (debug.print) what becomes of oRow (output row) & chcct (character count col) and both are 0 as the main Sub runs, despite both being initialized as 3 in the public Sub Row_Col_Num() below.
My public variables are at the top of the module before the first Sub() and denoted as Public. Sub Row_Col_Num() which contains the variable assignments is also Public. All Subs are in the same standard module.
Option Explicit
Public oRow As Integer 'row with "Objectives" text
Public aRow As Integer 'row with "Accomplishments" text
Public cOnA As Integer 'column that both obj and accmp text are in
Public cChCt As Integer 'column that the char count is output to
Public Sub Row_Col_Num()
oRow = 3
aRow = 5
cOnA = 1
cChCt = 3
Debug.Print "cchct pub sub: " & cChCt
End Sub
ATTEMPTS TO FIX PROBLEM & RESULTS
I used the variable normally and left it Public as well as the Sub that assigns the variables (oRow =3) values.
Sub TableCharCount_Obj()
'Run character count for the "Objectives" in the SELECTED table
Debug.Print "orow = " & oRow
Call TableCharCount(oRow, oRow) 'provide it 2x to make IF and FOR loop
End Sub
I tried putting the Sub() name in front of the variable when it is used, e.g. Row_Col_Num.orow, in the Sub above.
Call TableCharCount(Row_Col_Num.oRow, Row_Col_Num.oRow)
I tried the module name in front of the variable as well, e.g. Module1.orow.
Call TableCharCount(Module1.oRow, Module1.oRow)
RESULTS
#1 & #3 resulted in the macro counting the wrong row and outputting to the wrong cell.
#2 resulted in error "Expected Function or variable" at line: Call TableCharCount(Row_Col_Num.oRow, Row_Col_Num.oRow)
All 3 cases orow and cchct both continued to be 0 throughout the run.
QUESTIONS / SOLUTIONS
a) Can a Public variable (oRow) be used as an argument passed from calling Sub to called Sub as ByVal a As Integer?
b) Does Public Sub Row_Col_Num(), which assigns values to the public variables, have to be explicitly run or called to populate the variables in the other Subs w/ the correct values?
c) Should I call Public Sub Row_Col_Num() in every calling Sub before calling the main Sub?
Sub TableCharCount_Obj()
Call Public Sub Row_Col_Num() '<<< add this call
Call TableCharCount(oRow, oRow) 'provide it 2x to make IF and FOR loop
End Sub
This option seems like a bad design.
If it's not obvious, there was some mission creep as I added more capability For now, if I could get the public variables to work, it would be done. Appreciate any suggestion to get these variables to work. For the purposes of this question, I only left the code for the variable Sub, the first calling Sub and the main Sub. VBA below:
'#0 -- This creates variables for column and row number used in all the macros. Only need to change row/col number here if row/col are added/deleted
Option Explicit
Public oRow As Integer 'row with "Objectives" text
Public aRow As Integer 'row with "Accomplishments" text
Public cOnA As Integer 'column that both obj and accmp text are in
Public cChCt As Integer 'column that the char count is output to
'This assigns row/column numbers to the variables
Public Sub Row_Col_Num()
oRow = 3
aRow = 5
cOnA = 1
cChCt = 3
Debug.Print "cchct pub sub: " & cChCt End Sub
'#2
Sub TableCharCount_Obj() 'Run character count for the "Objectives" in the SELECTED table
Debug.Print "orow = " & oRow
Call TableCharCount(oRow, oRow) 'provide it 2x to make IF and FOR loop
End Sub
'other calling procedures removed
'#5
Option Explicit
Sub TableCharCount(ByVal a As Integer, ByVal b As Integer)
'Counts total characters in a cell w/in a table and outputs the number to a different cell, and colors the cell red or green if over/under the maximum number of characters.
Dim charCount, charWSCount, paraCount, charTot As Double
Dim iRng, oRng, txtRng As Word.Range
Dim i, max, s, t, x As Integer
Dim tcount, tbl As Integer
Dim DocT As Table 'for active doc tables
Debug.Print "cchct1= " & cChCt 'Debug.Print vbCr & "-----START-------" & vbCr Application.ScreenUpdating = False
If a <> b Then
tcount = ActiveDocument.Tables.Count
tbl = 1 'used in FOR loop, start w/ table #1
s = b - a '"STEP" used in FOR loop = # of rows between objectives text and accomplishments text Else
On Error GoTo ErrMsg 'handles expected user error of not selecting a table to execute on
tbl = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count 'ID the table that is selected
tcount = tbl 'prevents FOR loop from trying to run again
s = 1 '"STEP" used in FOR loop = # of rows between objectives text and accomplishments text / do not set to zero = infinite loop End If
'Debug.Print "# of Tables: " & tcount
For t = tbl To tcount 'loops thru the tables
Set DocT = ActiveDocument.Tables(t)
For x = a To b Step s 'loops thru the applicable row(s) in the table
'Debug.Print "x # start = " & x
'Debug.Print "table " & t
iRng = DocT.Cell(x, cOnA)
iRng.Select
'Count used in output
Selection.MoveLeft wdCharacter, 1, wdExtend 'computerstats requires the text itself selected, characters.count can use the whole cell selected
charWSCount = Selection.Range.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces) 'counts bullets & space after bullet / not line breaks (paragraphs)
'Debug.Print "Comp statchar# " & charWSCount
'---------
paraCount = Selection.Range.ComputeStatistics(Statistic:=wdStatisticParagraphs)
'Debug.Print "#paras = " & paraCount
'----------
charTot = charWSCount + paraCount
'Output to table cell
i = x - 1 'output cell is 1 row above cell that is counted
Set oRng = DocT.Cell(i, cChCt).Range 'Char count ouput row,column
Debug.Print "cchct2= " & cChCt
oRng.Text = charTot
Set txtRng = DocT.Cell(i, cChCt - 1).Range '"# Char:" location row,column
txtRng.Text = "# Char:"
'Maximum # of char allowed in a cell. Used to change cell fill red or green.
max = 2000 '"Accomplishment" row (row 5) has a max of 2000
If i = 2 Then max = 1500 '"Objective" row (row 3) has a max of 1500
'Change color of cell to indicate over/under max # of characters
If charCount < max Then
oRng.Shading.BackgroundPatternColor = wdColorBrightGreen
Else: oRng.Shading.BackgroundPatternColor = wdColorRed
End If
'Debug.Print "x # end = " & x
'Debug.Print "--------Next x--------------"
Next x
'Debug.Print "------Next Table------"
Next t
ActiveDocument.Tables(tbl).Select 'attempt to move to top of 1st table if using CharCount_AllTab() or just to the top of the selected table for the other macros
Selection.GoTo What:=wdGoToBookmark, Name:="\Page" Selection.StartOf
Application.ScreenUpdating = True
Exit Sub
ErrMsg: Msgbox "Select a table by placing the cursor anywhere in the table. Press OK and try the macro again numnuts!", _
vbOKOnly, "Table not selected"
End Sub

Related

Using If Conditionals to Exit For Loops VBA/VB

I am creating a third party add in for my CAD program that has a sub in it that goes through a drawing and finds all the parts lists (BOMS), if any items in the parts list are shared between the BOM (1 part being used in 2 weldments for example) then it changes the item number of the second instance to be that of the first instance. It does this by comparing full file names between the two values. When they match change the number to that of the matcher. I have got this to work but it runs a little slow because for a 100 item BOM each item is compared to 100 and thus that takes a little longer then I would like (about 60seconds to run). After thinking about it I realized I did not need to compare each item to all the items, I just needed to compare until it found a duplicate and then exit the search loop and go to the next value. Example being Item 1 does not need to compare to the rest of the 99 values because even if it does have a match in position 100 I do not want to change item 1s number to that of item 100. I want to change item 100 to that of 1(ie change the duplpicate to that of the first encountered double). For my code however I am having trouble exiting the comparison for loops which is causing me trouble. An example of the trouble is this:
I have 3 BOMs, each one shares Part X, and is numbered 1 in BOM 1, 4 in BOM 2, and 7 in BOM 3. when I run my button because I cannot get it to leave the comparison loop once it finds it first match all the Part X's ended up getting item number 7 from BOM 3 because it is the last instance. (I can get this to do what I want by stepping through my for loops backwards and thus everything ends up as the top most occurrence, but I would like to get my exit fors working because it saves me on unnecessary comparisons)
How do I go about breaking out of the nested for loops using an if conditional?
Here is my current code:
Public Sub MatchingNumberR1()
Debug.Print ThisApplication.Caption
'define active document as drawing doc. Will produce an error if its not a drawing doc
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Store all the sheets of drawing
Dim oSheets As Sheets
Set oSheets = oDrawDoc.Sheets
Dim oSheet As Sheet
'Loop through all the sheets
For Each oSheet In oSheets
Dim oPartsLists As PartsLists
Set oPartsLists = oSheet.PartsLists
'Loop through all the part lists on that sheet
Dim oPartList As PartsList
'For every parts list on the sheet
For Each oPartList In oPartsLists
For i3 = 1 To oPartList.PartsListRows.Count
'Store the Item number and file referenced in that row to compare
oItem = FindItem(oPartList)
oDescription = FindDescription(oPartList)
oDescripCheck = oPartList.PartsListRows.Item(i3).Item(oDescription).Value
oNumCheck = oPartList.PartsListRows.Item(i3).Item(oItem).Value
'Check to see if the BOM item is a virtual component if it is do not try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count = 0 Then
oRefPart = " "
End If
'Check to see if the BOM item is a virtual component if it is try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count > 0 Then
oRefPart = oPartList.PartsListRows.Item(i3).ReferencedFiles.Item(1).FullFileName
End If
MsgBox (" We are comparing " & oRefPart)
'''''Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match.'''''
'Store all the sheets of drawing
Dim oSheets2 As Sheets
Set oSheets2 = oDrawDoc.Sheets
Dim oSheet2 As Sheet
'For every sheet in the drawing
For Each oSheet2 In oSheets2
'Get all the parts list on a single sheet
Dim oPartsLists2 As PartsLists
Set oPartsLists2 = oSheet2.PartsLists
Dim oPartList2 As PartsList
'For every parts list on the sheet
For Each oPartList2 In oPartsLists2
oItem2 = FindItem(oPartList2)
oDescription2 = FindDescription(oPartList2)
'Go through all the rows of the part list
For i6 = 1 To oPartList2.PartsListRows.Count
'Check to see if the part is a not a virtual component, if not, get the relevent comparison values
If oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count > 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oRefPart2 = oPartList2.PartsListRows.Item(i6).ReferencedFiles.Item(1).FullFileName
'Compare the file names, if they match change the part list item number for the original to that of the match
If oRefPart = oRefPart2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
'For virtual components get the following comparison values
ElseIf oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count = 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oDescripCheck2 = oPartList2.PartsListRows.Item(i6).Item(oDescription2).Value
'Compare the descriptions and if they match change the part list item number for the original to that of the match
If oDescripCheck = oDescripCheck2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
Else
''''''''This is where if no matches were found I want it to continue going through the comparison loop'''''''
End If
Next
Next
Next
Next
Next
Next
'MsgBox ("Matching Numbers has been finished")
End Sub
For escape from nested for loop you can use GoTo and specify where.
Sub GoToTest()
Dim a, b, c As Integer
For a = 0 To 1000 Step 100
For b = 0 To 100 Step 10
For c = 0 To 10
Debug.Print vbTab & b + c
If b + c = 12 Then
GoTo nextValueForA
End If
Next
Next
nextValueForA:
Debug.Print a + b + c
Next
End Sub
Here are a few examples that demonstrate (1) breaking out of (exiting) a loop and (2) finding the values in arrays.
The intersection of 2 arrays example can be modified to meet your need to "Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match." Note, you may find multiple matches between 2 arrays.
Option Explicit
Option Base 0
' Example - break out of loop when condition met.
Public Sub ExitLoopExample()
Dim i As Integer, j As Integer
' let's loop 101 times
For i = 0 To 100:
j = i * 2
'Print the current loop number to the Immediate window
Debug.Print i, j
' Let's decide to break out of the loop is some
' condition is met. In this example, we exit
' the loop if j>=10. However, any condition can
' be used.
If j >= 10 Then Exit For
Next i
End Sub
' Example - break out of inner loop when condition met.
Public Sub ExitLoopExample2()
Dim i As Integer, j As Integer
For i = 1 To 5:
For j = 1 To 5
Debug.Print i, j
' if j >= 2 then, exit the inner loop.
If j >= 2 Then Exit For
Next j
Next i
End Sub
Public Sub FindItemInArrayExample():
' Find variable n in array arr.
Dim intToFind As Integer
Dim arrToSearch As Variant
Dim x, y
intToFind = 4
arrToSearch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
x = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(x) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; x
End If
intToFind = 12
y = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(y) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; y
End If
End Sub
Public Function FindItemInArray(FindMe, ArrayToSearch As Variant):
Dim i As Integer
For i = LBound(ArrayToSearch) To UBound(ArrayToSearch)
If FindMe = ArrayToSearch(i) Then
FindItemInArray = ArrayToSearch(i)
Exit For
End If
Next i
End Function
' Create a comparison loop to go through the drawing that checks
' the oRefPart against other BOM items and see if there is a match.
Public Sub ArrayIntersectionExample():
Dim exampleArray1 As Variant, exampleArray2 As Variant
Dim arrIntersect As Variant
Dim i As Integer
' Create two sample arrays to compare
exampleArray1 = Array(1, 2, 3, 4, 5, 6, 7)
exampleArray2 = Array(2, 4, 6, 8, 10, 12, 14, 16)
' Call our ArrayIntersect function (defined below)
arrIntersect = ArrayIntersect(exampleArray1, exampleArray2)
' Print the results to the Immediate window
For i = LBound(arrIntersect) To UBound(arrIntersect)
Debug.Print "match " & i + 1, arrIntersect(i)
Next i
End Sub
Public Function ArrayIntersect(arr1 As Variant, arr2 As Variant) As Variant:
' Find items that exist in both arr1 and arr2 (intersection).
' Return the intersection as an array (Variant).
Dim arrOut() As Variant
Dim matchIndex As Long
Dim i As Long, j As Long
' no matches yet
matchIndex = -1
' begin looping through arr1
For i = LBound(arr1) To UBound(arr1)
' sub-loop for arr2 for each item in arr1
For j = LBound(arr2) To UBound(arr2)
' check for match
If arr1(i) = arr2(j) Then
' we found an item in both arrays
' increment match counter, which we'll
' use to size our output array
matchIndex = matchIndex + 1
' resize our output array to fit the
' new match
ReDim Preserve arrOut(matchIndex)
' now store the new match our output array
arrOut(matchIndex) = arr1(i)
End If
Next j
Next i
' Have the function return the output array.
ArrayIntersect = arrOut
End Function

Excel VBA : Auto numbering

I'm creating a database on Excel, and encountered some problems as I tried to assign auto number to each row.
Requirements are:
generate auto number to each row(on the column A) when column B is not blank.
the number should be unique and must always be connected to the contents of the same row even when the column is sorted or when new rows are inserted, etc.
when a new row is inserted (anywhere on the same column), a new number should be assigned (the newest number should be the biggest number)
if
possible, the auto number should have a prefix, and number should be displayed in four digits (e.g. 0001, 0011)
I have tried some VBA codes I found from other people's questions (e.g. Excel VBA : Auto Generating Unique Number for each row).
So far, the code below has worked the best, but the requirement (3) and (4) couldn't be solved by that code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim maxNumber
If Not Intersect(Target, Range("B:B")) Is Nothing Then
' don't run when more than one row is changed
If Target.Rows.Count > 1 Then Exit Sub
' if column A in the current row has a value, don't run
If Cells(Target.Row, 1) > 0 Then Exit Sub
' get the highest number in column A, then add 1 and write to the
' current row, column A
maxNumber = Application.WorksheetFunction.Max(Range("A:A"))
Target.Offset(0, -1) = maxNumber + 1
End If
End Sub
I'm short of the knowledge of VBA and I hope someone could help me this.
Many thanks.
Alternative via CustomDocumentProperties
Instead of using a hidden sheet as proposed by #TimWilliams, one can assign incremented values to a user defined custom document property (CDP), naming it e.g. "InvNo" holding the newest invoice number. The cdp remain stored in the saved workbook.
The function below gets the current number saved to this workbook related property and returns the next number by adding 1 to the current value. It uses a help procedure RefreshCDP to assign the new value (could be used of course independantly to reset values programmaticaly to any other value). - If the cdp name isn't passed as (optional) argument, the function assumes "InvNo" by default.
Note that code requires some error handling to check if the cdp exists.
Example call
Dim InvoiceNumber as Long
InvoiceNumber = NextNumber("InvNo") ' or simply: NextNumber
Public Function NextNumber(Optional CDPName As String = "InvNo") As Long
'a) get current cdp value
Dim curVal As Long
On Error Resume Next
curVal = ThisWorkbook.CustomDocumentProperties(CDPName)
If Err.Number <> 0 Then Err.Clear ' not yet existing, results in curVal of 0
'b) increment current cdp value by one to simulate new value
Dim newVal As Long
newVal = curVal + 1
'Debug.Print "Next " & CDPName & " will be: " & newVal
'c) assign new value to custom document property
RefreshCDP CDPName, newVal, msoPropertyTypeNumber
'Debug.Print "New " & CDPName & " now is: " & ThisWorkbook.CustomDocumentProperties(CDPName)
NextNumber = newVal
End Function
Help procedure RefreshCDP
Sub RefreshCDP(CDPName As String, _
newVal As Variant, docType As Office.MsoDocProperties)
On Error Resume Next
ThisWorkbook.CustomDocumentProperties(CDPName).Value = newVal
'If cdp doesn't exist yet, create it (plus adding the new value)
If Err.Number > 0 Then
ThisWorkbook.CustomDocumentProperties.Add _
Name:=CDPName, _
LinkToContent:=False, _
Type:=docType, _
Value:=newVal
End If
End Sub
Related links
MS help: Excel.Workbook.CustomDocumentProperties
Check if BuiltInDocumentProperty is set without error trapping
Chip Pearson: Document Properties
How to add a DocumentProperty to CustomDocumentProperties in Excel?
Do not use Max() to find the next number - use instead a hidden sheet or name to store the current number, and increment it each time a new Id is required.
For example:
Public Function NextNumber(SequenceName As String)
Dim n As Name, v
On Error Resume Next
Set n = ThisWorkbook.Names(SequenceName)
On Error GoTo 0
If n Is Nothing Then
'create the name if it doesn't exist
ThisWorkbook.Names.Add SequenceName, RefersTo:=2
v = 1
Else
'increment the current value
v = Replace(n.RefersTo, "=", "")
n.RefersTo = v + 1
End If
NextNumber = v
End Function
This allows you to use multiple different sequences as long as you give each one a distinct name.
Dim seq
seq = NextNumber("seqOne")
'etc

How to correctly set the list property? (Error 381)

I have created a listbox which can be filtered according to keyword in textbox. It works if I do it normally. However, it stopped working when the list is a dependent source. (The listbox value is like INDIRECT() of F1 and I'm trying to filter that INDIRECT list)
I have 3 lists as shown in the image (A, B, D). D is a list of A without duplicates. the listbox("lbxCustomers") in Userform2 uses a dependent rowsource according to word selected at Cell F2. [It works until here]
The values in the listbox will be filtered according to keyword in textbox("tbxFind"). I'm getting an error at this line ".List = vaCustNames". I tried to change it into a normal range (sheet1.range(...)) and it works but the list is not a dependent list of F1.
image
Private Sub UserForm_Initialize()
Me.lbxCustomers.RowSource = Range("F2").Value
End Sub
Private Sub tbxFind_Change()
Dim i As Long
Dim sCrit As String
Dim vaCustNames As Variant
vaCustNames = Range("F2").Value
Debug.Print Range("F2").Value
sCrit = "*" & UCase(Me.tbxFind.Text) & "*"
With Me.lbxCustomers
.RowSource = ""
'Start with a fresh list
.List = vaCustNames
'.List = Sheet1.Range("B2:B13").Value 'tested with range and worked
For i = .ListCount - 1 To 0 Step -1
'Remove the line if it doesn’t match
If Not UCase(.List(i)) Like sCrit Then
.RemoveItem i
End If
Next i
End With
End Sub

Error Adding Table to document - Object variable or with block variable is not set

I am working with VBA for the first time in a long time and need some help with adding a table into the document.
the line in question at the moment is
.Cell(1, x).Range.Select
and the error that I get is object variable or with block variable is not set. and for the life of me I cannot see where I am going wrong on this one.
I am passing in a 3 dimensional string array that I am looking to pass into a table and this is the code I am working with at the moment
Private Sub Create_Sized_Table_Multi_Column(i_Rows As Integer, i_Columns As Integer)
'create a table
Set t_newtable = ActiveDocument.Tables.Add(Selection.Range, i_Rows, i_Columns)
End Sub
Private Sub BuildTable(arr() As String, colCount As Integer, bookMark As String)
Dim t_newtable As Table
Dim i_Fund_Quantity As Integer
Dim i_Rows_Required As Integer
Dim i_Columns_Required As Integer
'Number of funds is the upperbound + 1 to allow for the zero relative
i_Fund_Quantity = UBound(arr) + 1
'header Row
i_Rows_Required = UBound(arr) + 1
'Number of columns
i_Columns_Required = colCount
'Add a table - this table will contain moved funds
'creates the table dimensioned by i_rows x i_column
Create_Sized_Table_Multi_Column i_Rows_Required, i_Columns_Required
'Now populate the header row
With t_newtable
For x = 0 To i_Columns_Required
.Cell(1, x).Range.Select
If x = 1 Then
Set_Table_Headers "Existing Fund"
ElseIf x = 2 Then
Set_Table_Headers "Customer Name"
ElseIf x = 3 Then
Set_Table_Headers "Switch To"
ActiveDocument.Bookmarks.Add ("bk_Switched_Table")
End If
Next
End With
'Populate the table with the fund details
''//sp write to table here
With t_newtable
'Position cursor at first insertion point
'ActiveDocument.Bookmarks("bk_Switched_Table").Select
'Now create a loop
For i_Loop_Rows = 0 To UBound(arr)
Set_Table_Rows
Selection.TypeText arr(i, 0)
Selection.MoveRight UNIT:=wdCell
Selection.TypeText arr(i, 1)
Selection.MoveRight UNIT:=wdCell
Selection.TypeText arr(i, 2)
t_newtable.Columns(3).Select
t_newtable.Columns.AutoFit
Selection.Collapse Direction:=wdCollapseEnd
Next
End With
ActiveDocument.Bookmarks(bookMark).Select
Selection.TypeParagraph
Selection.TypeText s_Text
Selection.TypeParagraph
ActiveDocument.Bookmarks.Add (bookMark)
End Sub
I would be grateful if someone could review this and let me know where I have gone wrong and what I need to change.
thanks
Simon
You declare t_newtable in the procedure Create_Sized_Table_Multi_Column, so it will be limited to that scope. If you want to call that procedure, have it create the table, then make it available to the code that called it, you need to change the Sub into a Function and have the function return the table.
For example:
Private Function Create_Sized_Table_Multi_Column(i_Rows As Integer, _
i_Columns As Integer) As Table
'create a table
Set Create_Sized_Table_Multi_Column = ActiveDocument.Tables.Add( _
Selection.Range, i_Rows, i_Columns)
End Function
Then you use it like this (code shortened for clarity):
Private Sub BuildTable(arr() As String, colCount As Integer, bookMark As String)
Dim t_newtable As Table
'Add a table - this table will contain moved funds
'creates the table dimensioned by i_rows x i_column
Set t_newtable = Create_Sized_Table_Multi_Column(i_Rows_Required, _
i_Columns_Required)
End Sub
Note the added parenthesis around the call to the function. These are required when something is to be returned from a call.
You never set t_newtable in your BuildTable sub. If you have to create your table somewhere else, then you have to
Set t_newtable = ActiveDocument.Tables(indexOfYourTable)
which will instantiate your t_newtable to the object you want it to be. NOTE: indexOfYourTable is 1 based not 0 based.
OR
You can put the line of code in your Create_Sized_Table_Multi_Column sub inside your BuildTable sub and pass the variables needed into your BuildTable sub.

Copy unique records from one workbook to another master workbook

I need some help with copying unique records from one workbook to a master workbook please.
Each month I receive a new workbook with data and I want to be able to copy all new records in that new workbook to one master workbook which will have all the amalgamted records. There is one unique reference field which can be used for the lookup to identify a new record.
In addition to this what I want to do is update values which are in 3 columns for ALL existing records on the master workbook which might be on the new workbook.
Example
Master workbook
Ref Name Value 1 Value 2 Value 3 Description
123 TR 100 50 200 xxxxxxxxxxxxxxx
111 WE 90 45 400 xxxxxxxxxxxxxxx
New workbook
Ref Name Value 1 Value 2 Value 3 Description
123 TR 300 200 200 xxxxxxxxxxxxxxx
456 MA 100 500 700 xxxxxxxxxxxxxxx
Update master workbook
Ref Name Value 1 Value 2 Value 3 Description
123 TR 300 200 200 xxxxxxxxxxxxxxx
111 WE 90 45 400 xxxxxxxxxxxxxxx
456 MA 100 500 700 xxxxxxxxxxxxxxx
I'd appreciate any help with this please. Thanks
I wrote a small module that does what you want (and even more). I tried to make it as generic as possible, but I had to assert a few things and limit it somehow - otherwise it would get quickly out of hand (as I think it already did.. kind of).
The limitations/assertions are the following:
1. the records are considered to be laid out only in rows (as per your example).
2. there is no column checking during the update or insertion of values. The program assumes that both master and new workbooks contain the same columns and laid in the exact same order.
3. There is no validation check for duplicate reference values. The "ref" column that you indicate as your primary key in each data range, is assumed to contain unique values (for that data range).
Apart from those assumptions, my solution is enhanced with flexible arguments (optional or autoconfigurable - see how dataRange is determined) to allow for several types of operation.
optional colorAlertOption flag: allows updated or inserted entries to be colored in order to be more distinguisable (true by default)
optional rangeWithHeaders flag: helps to determine if the supplied dataRange argument needs to be resized (remove headers) or not (true by default)
optional refColIndex integer: the relative to the dataRange - not the whole worksheet - column number pinpointing the column containing the unique references. (1 by default)
required dataRangeNew, dataRangeMaster (Range) arguments: flexible representations of the data-ranges for the new and master datasets respectively. You can either provide them explicitly (e.g. "$A$1:$D$10") or by giving only a single cell contained anywhere within the data-range. The only predicates are that the data-range should be isolated from other possible data coexisting on the same sheet (by means of blank rows or columns) and that it contains at least 1 row.
You can call the updateMasterDataRange procedure like this:
call updateMasterDataRange (Workbooks(2).Sheets("new").Range("a1"), Workbooks(1).Worksheets("master").Range("a1"))
Notice the fully qualified data ranges, including the workbooks and the worksheets in the mix. If you don't prepend these identifiers, VBA will try to associate the unqualified Range with ActiveWorkbook or/and ActiveWorksheet, with unpredictable results.
Here goes the body of the module:
Option Explicit
Option Base 1
Public Sub updateMasterDataRange( _
ByRef dataRangeNew As Range, ByRef dataRangeMaster As Range, _
Optional refColIndexNew As Integer = 1, Optional refColIndexMaster As Integer = 1, _
Optional colorAlertOption = True, Optional rangeWithHeaders = True)
' Sanitize the supplied data ranges based on various criteria (see procedure's documentation)
If sanitizeDataRange(dataRangeMaster, rangeWithHeaders) = False Then GoTo rangeError
If sanitizeDataRange(dataRangeNew, rangeWithHeaders) = False Then GoTo rangeError
' Declaring counters for the final report's updated and appended records respectively
Dim updatedRecords As Integer: updatedRecords = 0
Dim appendedRecords As Integer: appendedRecords = 0
' Declaring the temporary variables which hold intermediate results during the for-loop
Dim updatableMasterRefCell As Range, currentRowIndex As Integer, updatableRowMaster As Range
For currentRowIndex = 1 To dataRangeNew.Rows.Count
' search the master's unique references (refColMaster range) for the current reference
' from dataRangeNew (refcolNew range)
Set updatableMasterRefCell = dataRangeMaster.Columns(refColIndexMaster).Find( _
what:=dataRangeNew.Cells(currentRowIndex, refColIndexNew).Value, _
lookat:=xlWhole, searchorder:=xlByRows, searchDirection:=xlNext)
' perform a check to see if the search has returned a valid range reference in updatableMasterRefCell
' if it is found empty (the reference value in refCellNew is unique to masterDataRange)
If updatableMasterRefCell Is Nothing Then
Call appendRecord(dataRangeNew.Rows(currentRowIndex), dataRangeMaster, colorAlertOption)
appendedRecords = appendedRecords + 1
'ReDim Preserve appendableRowIndices(appendedRecords)
'appendableRowIndices(appendedRecords) = currentRowIndex
Else
Set updatableRowMaster = Intersect(dataRangeMaster, updatableMasterRefCell.EntireRow)
Call updateRecord(dataRangeNew.Rows(currentRowIndex), updatableRowMaster, colorAlertOption)
updatedRecords = updatedRecords + 1
End If
Next currentRowIndex
' output an informative dialog to the user
Dim msg As String
msg = _
"sheet name: " & dataRangeMaster.Parent.Name & vbCrLf & _
"records updated: " & updatedRecords & vbCrLf & _
"records appended: " & appendedRecords
MsgBox msg, vbOKOnly, "--+ Update report +--"
Exit Sub
rangeError:
MsgBox "Either range argument is too small to operate on!", vbExclamation, "Argument Error"
End Sub
Sub appendRecord(ByVal recordRowSource As Range, ByRef dataRangeTarget As Range, Optional ByVal colorAlertOption As Boolean = True)
Dim appendedRowTarget As Range
Set dataRangeTarget = dataRangeTarget.Resize(Rowsize:=dataRangeTarget.Rows.Count + 1)
Set appendedRowTarget = dataRangeTarget.Rows(dataRangeTarget.Rows.Count)
appendedRowTarget.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
Set appendedRowTarget = appendedRowTarget.Offset(-1, 0)
' resize datarangetarget to -1 row (because cells' shifting incurred a +1 row to dataRangeTarget)
Set dataRangeTarget = dataRangeTarget.Resize(Rowsize:=dataRangeTarget.Rows.Count - 1)
recordRowSource.Copy appendedRowTarget
If colorAlertOption = True Then
' fills the cells of the newly appended row with lightgreen color
appendedRowTarget.Interior.color = RGB(156, 244, 164)
End If
End Sub
Sub updateRecord(ByVal recordRowSource As Range, ByVal updatableRowTarget As Range, Optional ByVal colorAlertOption As Boolean = True)
recordRowSource.Copy updatableRowTarget
If colorAlertOption = True Then
' fills the cells of the updated row with lightblue color
updatableRowTarget.Interior.color = RGB(164, 189, 249)
End If
End Sub
Private Function sanitizeDataRange(ByRef target As Range, ByVal rangeWithHeaders As Boolean) As Boolean
' if data range comprises only 1 cell then try to expand the range to currentRegion
' (all neighbouring cells until the selection reaches boundaries of blank rows or columns)
If target.Cells.Count = 1 Then
Set target = target.CurrentRegion
End If
' remove headers from data ranges if flag RangeWithHeaders is true
If (rangeWithHeaders) Then
If (target.Rows.Count >= 2) Then
Set target = target.Offset(1, 0).Resize(Rowsize:=(target.Rows.Count - 1))
Else
sanitizeDataRange = False
End If
End If
sanitizeDataRange = IIf((target.Rows.Count >= 1), True, False)
End Function
The results of a simple execution on your example gave the expected results, as you can see in the attached picture. There is even a dialogue with a brief report on the accomplished operations.
You haven't got much of a start. Will this outline get you started?
open all 3 workbooks
for masterrow = beginrow to endrow
if match in newsheet then
updaterow = newrow
else
updaterow = masterrow
end if
next masterrow
' now pick up unmatched newrows
for newrow = beginrow to endrow
if not match in updatesheet then
updaterow = newrow
end if
next newrow
EDIT: CodeVortex did the whole thing. My outline was flawed.
open both workbooks
appendrow = endrow of mastersheet
for newrow = beginrow to endrow
if match in mastersheet then
update masterrow
else
append into appendrow
appendrow = appendrow + 1
end if
next newrow