I am putting together a Bar Bending Schedule for the Building Industry. I am new to excel vba and am doing my best but have stumbled across a problem that I am struggling to find a solution to.
I am working with the following objects in my project;
Worksheet "BBS"
Worksheet "Shapes"
Userform "BBSForm"
I have shapes grouped with textboxes on the "Shapes" worksheet. Example shape is "L" which is an L-shaped Bar with 2 dimensions and hence 2 textboxes.
When the "L" shape is chosen on the userform and textbox dimensions are entered I click a button that submits the entry to the "BBS" worksheet. It copies the "Lgroup" from the shapes sheet and pastes it into the "BBS" sheet.
The problem occurs when I have 2 textboxes as once pasted they change name and I need to know their names so I can populate them with the dimensions.
I have the code below so far but the L shape doesn't work as "Forms.TextBox.2" doesn't exist, both textboxes in the group are "Forms.TextBox.1".
Sub ShapeSelectCopy()
Dim CodeSh As String
CodeSh = BBSForm.TextBoxShp.Value
Worksheets("BBS").Activate
Range("A1").End(xlDown).Offset(0, 5).Select
Dim nextsh As Range
Set nextsh = Selection
Select Case CodeSh
Case "S"
Sheets("Shapes").Select
ActiveSheet.Shapes.Range(Array("Group 13")).Select
Selection.Copy
Sheets("BBS").Select
ActiveSheet.Paste
Dim newname As String
newname = Sheets("BBS").Range("A1").End(xlDown).Offset(0, 0).Value
Selection.Name = newname
With Selection
.Left = nextsh.Left + (nextsh.Width - Selection.Width) / 2
.Top = nextsh.Top + (nextsh.Height - Selection.Height) / 2
End With
Dim shpG As Shape, shp As Shape
Dim objOLE As OLEObject
Set shpG = ActiveSheet.Shapes(newname)
For Each shp In shpG.GroupItems
Set objOLE = shp.OLEFormat.Object
If objOLE.progID = "Forms.TextBox.1" Then objOLE.Object.Value = BBSForm.TextBoxA.Value
Next
Case "L"
Sheets("Shapes").Select
ActiveSheet.Shapes.Range(Array("Group 12")).Select
Selection.Copy
Sheets("BBS").Select
ActiveSheet.Paste
Dim newname As String
newname = Sheets("BBS").Range("A1").End(xlDown).Offset(0, 0).Value
Selection.Name = newname
With Selection
.Left = nextsh.Left + (nextsh.Width - Selection.Width) / 2
.Top = nextsh.Top + (nextsh.Height - Selection.Height) / 2
End With
Dim shpG As Shape, shp As Shape
Dim objOLE As OLEObject
Set shpG = ActiveSheet.Shapes(newname)
For Each shp In shpG.GroupItems
Set objOLE = shp.OLEFormat.Object
If objOLE.progID = "Forms.TextBox.1" Then objOLE.Object.Value = BBSForm.TextBoxA.Value
If objOLE.progID = "Forms.TextBox.2" Then objOLE.Object.Value = BBSForm.TextBoxB.Value
Next
End Select
End Sub
Any Help would be greatly appreciated.
Factoring out some of the repeated code here's one approach:
Sub ShapeSelectCopy()
Dim CodeSh As String
Dim nextsh As Range
Dim shtShapes As Worksheet, shtBBS As Worksheet
Dim shpToCopy As String, val1, val2
Dim tbCount As Long
Dim shpG As ShapeRange, shp As Shape, pid
Set shtShapes = Worksheets("Shapes")
Set shtBBS = Worksheets("BBS")
Set nextsh = shtBBS.Range("A1").End(xlDown).Offset(0, 5)
shpToCopy = ""
CodeSh = BBSForm.TextBoxShp.Value
Select Case CodeSh
Case "S"
shpToCopy = "Group 13"
val1 = BBSForm.TextBoxA.Value
val2 = ""
Case "L"
shpToCopy = "Group 12"
val1 = BBSForm.TextBoxA.Value
val2 = BBSForm.TextBoxB.Value '<< edit to fix typo
End Select
If shpToCopy = "" Then Exit Sub 'exit if no shape to copy
'copy the shape
shtShapes.Shapes(shpToCopy).Copy
shtBBS.Activate
shtBBS.Paste
Set shpG = Selection.ShapeRange
'name and position
With shpG
.Name = shtBBS.Range("A1").End(xlDown).Value
.Left = nextsh.Left + (nextsh.Width - shpG.Width) / 2
.Top = nextsh.Top + (nextsh.Height - shpG.Height) / 2
End With
'populate textbox(es)
tbCount = 0
For Each shp In shpG.GroupItems
On Error Resume Next
pid = shp.OLEFormat.progID
On Error GoTo 0
'Debug.Print ">>>", pid
If pid = "Forms.TextBox.1" Then
tbCount = tbCount + 1
If tbCount = 1 Then shp.OLEFormat.Object.Object.Value = val1
If tbCount = 2 Then shp.OLEFormat.Object.Object.Value = val2
End If
Next shp
End Sub
Related
I'm trying to create the following template:
The user creates a table in a "Data Entry" worksheet that lists the following:
File path ie: P:\Phone Camera Dump\20121224_111617.jpg
Range where the picture is to be placed in the "PICS" worksheet.
Once the list is finalized, the user executes and images are placed within the ranges specified on the "PICS" worksheet and dynamically re-sized.
Presently the range has a set width of 624px and a height of 374px, but ideally, I would like the image to resize (aspect ratio not locked) dynamically in the width and height change.
I've used the following code as a base but am struggling with how to incorporate the cell ranges instead of the static row updates:
Sub InsertSeveralImages()
Dim pic_Path As String 'File path of the picture
Dim cl As Range, Rng As Range
Dim WS_Templte As Worksheet
Set WS_Templte = Worksheets("PICS")
Set Rng = Worksheets("Data Entry").Range("C13:C42")
pastingRow = 2
For Each cl In Rng
pic_Path = cl.Value
Set InsertingPicture = WS_Templte.Pictures.Insert(pic_Path)
'Setting of the picture
With InsertingPicture
.ShapeRange.LockAspectRatio = msoTrue
.Height = 100
.Top = WS_Templte.Rows(pastingRow).Top
.Left = WS_Templte.Columns(3).Left
End With
pastingRow = pastingRow + 5
Next cl
Set myPicture = Nothing
WS_Templte.Activate
End Sub
Any thoughts?
I figured it out. Here is the code in case anyone wants to use it:
Public Sub InsertPictures()
Dim vntFilePath As Variant
Dim rngFilePath As Range
Dim vntPastePath As Variant
Dim rngPastePath As Range
Dim lngCounter As Long
Dim pic As Picture
Set WS_Templte = Worksheets("PICS")
On Error GoTo ErrHandler
With ThisWorkbook.Sheets("PICS") '<-- Change sheet name accordingly
' Set first cell containing a row number
Set rngFilePath = .Range("BJ7")
vntFilePath = rngFilePath.Value
' Set first cell containing a paste range
Set rngPastePath = .Range("BK7")
vntPastePath = rngPastePath.Value
Do Until IsEmpty(vntFilePath)
If Dir(vntFilePath) = "" Then vntFilePath = strNOT_FOUND_PATH
Set pic = .Pictures.Insert(vntFilePath)
lngCounter = lngCounter + 1
With pic
.ShapeRange.LockAspectRatio = msoFalse
If .ShapeRange.Rotation = 90! Or .ShapeRange.Rotation = 270! Then
.Height = Application.CentimetersToPoints(16.3)
.Width = Application.CentimetersToPoints(10.03)
.Top = WS_Templte.Rows(rngPastePath).Top - (.Height - .Width) / 2#
.Left = WS_Templte.Columns(4).Left + (.Height - .Width) / 2#
Else
.Width = Application.CentimetersToPoints(10.03)
.Height = Application.CentimetersToPoints(16.3)
.Top = WS_Templte.Rows(rngPastePath).Top
.Left = WS_Templte.Columns(4).Left
End If
End With
Set rngFilePath = rngFilePath.Offset(1)
vntFilePath = rngFilePath.Value
Set rngPastePath = rngPastePath.Offset(1)
vntPastePath = rngPastePath.Value
Loop
End With
MsgBox lngCounter & " pictures were inserted.", vbInformation
ExitProc:
Set rngFilePath = Nothing
Set pic = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitProc
End Sub
Long time listener, first time caller.
Anyway, I could use a bit of help. I have a macro that adds Text Boxes, and names them "Fig Num " & ActiveSheet.Shapes.count.
Once all of these text boxes are spread through out the Workbook, I would like to rename all shapes with the name "Fig Num*", or at least the text inside them, to go in order from first page to last, top to bottom, and left to right.
Currently, my code will rename the the text boxes based on seniority. In other words, if I added a text box and it was labeled "Fig Num 3", it would still be named "Fig Num 3" whether it was on the first page or last page.
enter code here
Sub Loop_Shape_Name()
Dim sht As Worksheet
Dim shp As Shape
Dim i As Integer
Dim Str As String
i = 1
For Each sht In ActiveWorkbook.Worksheets
For Each shp In sht.Shapes
If InStr(shp.Name, "Fig Num ") > 0 Then
sht.Activate
shp.Select
shp.Name = "Fig Num"
End If
Next shp
For Each shp In sht.Shapes
If InStr(shp.Name, "Fig Num") > 0 Then
sht.Activate
shp.Select
shp.Name = "Fig Num " & i
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
"FIG " & i
i = i + 1
End If
Next shp
Next sht
End Sub
---
I have a workbook example, but I'm not sure how to load it up, this being my first time and all.
Edit:
I have found a code that will do what I'm looking for, however it's a bit clunky. I also need a good way to find the last row on the sheet that contains a shape. Since the shape names are based on creation, if I insert a shape in row 35 and use the shape.count. featured below, it will skip all shapes after row 35 unless I add additional rows that bog down the code.
Most Recent Code (loops through grouped shapes):
Private Sub Rename_FigNum2()
'Dimension variables and data types
Dim sht As Worksheet
Dim shp As Shape
Dim subshp As Shape
Dim i As Integer
Dim str As String
Dim row As Long
Dim col As Long
Dim NextRow As Long
Dim NextRow1 As Long
Dim NextCol As Long
Dim rangex As Range
Dim LR As Long
i = 1
'Iterate through all worksheets in active workbook
For Each sht In ActiveWorkbook.Worksheets
If sht.Visible = xlSheetVisible Then
LR = Range("A1").SpecialCells(xlCellTypeLastCell).row + 200
If sht.Shapes.Count > 0 Then
With sht
NextRow1 = .Shapes(.Shapes.Count).BottomRightCell.row + 200
'NextCol = .Shapes(.Shapes.Count).BottomRightCell.Column + 10
End With
If LR > NextRow1 Then
NextRow = LR
Else
NextRow = NextRow1
End If
End If
NextCol = 15
Set rangex = sht.Range("A1", sht.Cells(NextRow, NextCol))
For row = 1 To rangex.Rows.Count
For col = 1 To rangex.Columns.Count
For Each shp In sht.Shapes
If shp.Type = msoGroup Then
For Each subshp In shp.GroupItems
If Not Intersect(sht.Cells(row, col), subshp.TopLeftCell) Is Nothing Then
If InStr(subshp.Name, "Fig Num") > 0 Then
subshp.Name = "Fig Num " & i
subshp.TextFrame2.TextRange.Characters.Text = _
"FIG " & i
i = i + 1
End If
End If
Next subshp
Else
If Not Intersect(sht.Cells(row, col), shp.TopLeftCell) Is Nothing Then
If InStr(shp.Name, "Fig Num ") > 0 Then
shp.Name = "Fig Num " & i
shp.TextFrame2.TextRange.Characters.Text = _
"FIG " & i
i = i + 1
End If
End If
End If
Next shp
Next col
Next row
End If
Next sht
End Sub
Example of Workbook:
Rename Text Boxes
To use the ArrayList, you have to have .NET Framework 3.5 SP1 installed, even if you already have a later version (e.g. 4.7) installed.
It is assumed that each text box is an ActiveX control (not a Form control) and has a (per worksheet) unique top-left cell.
Option Explicit
Sub RenameTextBoxes()
Const oTypeName As String = "TextBox" ' OLEObject Type Name
Const fPattern As String = "Fig Num " ' Find Pattern (Unsorted)
Const tPattern As String = "Dummy" ' Temporary Pattern
Const nPattern As String = "Fig Num " ' New Pattern (Sorted)
Const ByRows As Boolean = False
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet
Dim ole As OLEObject
Dim Key As Variant
Dim n As Long
Dim r As Long
Dim Coord As Double
Dim tName As String
For Each ws In wb.Worksheets
arl.Clear
dict.RemoveAll
For Each ole In ws.OLEObjects
If TypeName(ole.Object) = oTypeName Then
If InStr(1, ole.Name, fPattern, vbTextCompare) = 1 Then
n = n + 1
If ByRows Then
Coord = GetNumericByRows(ole.TopLeftCell)
Else
Coord = GetNumericByColumns(ole.TopLeftCell)
End If
arl.Add Coord
tName = tPattern & n
ole.Name = tName
dict(Coord) = tName
End If
End If
Next ole
arl.Sort
For Each Key In arl
r = r + 1
ws.OLEObjects(dict(Key)).Name = nPattern & r
'Debug.Print nPattern & r, Key, dict(Key)
Next Key
Next ws
End Sub
Function GetNumericByColumns( _
ByVal OneCellRange As Range) _
As Double
If OneCellRange Is Nothing Then Exit Function
With OneCellRange.Cells(1)
GetNumericByColumns = Val(.Column & "." & Format(.Row, "000000#"))
End With
End Function
Function GetNumericByRows( _
ByVal OneCellRange As Range) _
As Double
If OneCellRange Is Nothing Then Exit Function
With OneCellRange.Cells(1)
GetNumericByRows = Val(.Row & "." & Format(.Column, "0000#"))
End With
End Function
' Modify the range address to see what the 'GetNumeric' functions are all about.
Sub GetNumericTEST()
Dim cCell As Range: Set cCell = Sheet1.Range("XFD1048576")
Debug.Print GetNumericByColumns(cCell)
Debug.Print GetNumericByRows(cCell)
End Sub
I have the following table:
And a macro that loops through the first section of the table (rows 6-7) in order to create the Pie-Charts on the right. My target now is to loop through all other tables automatically as well. The next one would be in row11 and create a new Pie Chart for that row, then the next table (rows 15-16) and so on. The header of each table is always red. The problem is that the length of the tables vary, meaning for example in the table1 ("Build", A5:K7) there can be 2 rows like here or 50, but each time I need one PieChart for each row.
Currently I have the following working code for Table1 ("Build" A6:K79) to create the 2 PieCharts automatically, but Im unsure how to make one loop for all tables on the sheet.
Dim rownumber As Integer
Dim LabelRange As Range
Dim ValueRange As Range
Dim Chart As ChartObject
Dim LeftIndent As Long
Dim TopIndent As Long
Dim InhaltsRangeString As String
Dim LetzteZeile As Long
'Intialpositionen für Graphen
LeftIndent = 726
TopIndent = 60
rownumber = 6 'Anfang der Buildtabelle in Reihe 6 (Spalte 1)
Set LabelRange = ThisWorkbook.Worksheets("Testplan Überblick").Range("C5, E5, G5, I5")
Set TPsheet = Worksheets("Testplan Überblick")
Set ValueRange = Union(TPsheet.Cells(rownumber, 3), TPsheet.Cells(rownumber, 5), TPsheet.Cells(rownumber, 7), TPsheet.Cells(rownumber, 9))
'Loop through table 1 which always starts at row 6 (unlike the others which have no set starting point cause the ones before can vary in length!)
For rownumber = 6 To LetzteZeileFunktion Step 1 '"LetzteZeileFunktion" gives me the long value of the last row filled in table 1
Set Chart = Sheets("Testplan Überblick").ChartObjects.Add(Left:=180, Width:=270, Top:=7, Height:=210)
With Chart
.Chart.SetSourceData Source:=ValueRange
.Chart.ChartType = xlPie
.Chart.HasTitle = True
.Chart.SetElement (msoElementChartTitleAboveChart)
.Chart.ChartTitle.Text = Sheets("Testplan Überblick").Cells(rownumber, 1).Value
.Chart.FullSeriesCollection(1).XValues = LabelRange
.Left = LeftIndent
.Top = TopIndent
.Name = Sheets("Testplan Überblick").Cells(rownumber, 1).Value
End With
TopIndent = TopIndent + 225
Next rownumber
End Sub
Any ideas on how to loop through all the tables even though they can all differ in length (amount of rows filled with content for charts) would be greatly appreciated!
Cheers
Use the text in one of the headers to identify the start of the data rows and a blank in column A to end. I have used "testfall qty" in column B.
Option Explicit
Sub CreateCharts()
Const DATA = "Testplan Überblick"
Const ROW_START = 5
Const POSN_LEFT = 726
Const POSN_TOP = 60
Const COL = "B"
Const HEADER = "testfall qty"
Dim wb As Workbook, ws As Worksheet
Dim rngLabel As Range, rngValue As Range
Dim iRow As Long, iLastRow As Long, count As Integer
Dim oCht As ChartObject, sColA As String, bflag As Boolean
bflag = False
Set wb = ThisWorkbook
Set ws = wb.Sheets(DATA)
' scan down the sheet
iLastRow = ws.Cells(Rows.count, "A").End(xlUp).Row
For iRow = ROW_START To iLastRow
' look for Testfall Qty as header
sColA = ws.Cells(iRow, 1)
If LCase(ws.Cells(iRow, COL)) = HEADER Then
'set ranges
Set rngLabel = ws.Range("C1, E1, G1, I1").Offset(iRow - 1)
bflag = True
ElseIf Len(sColA) > 0 And bflag Then
' create chart
Set rngValue = ws.Range("C1, E1, G1, I1").Offset(iRow - 1)
Set oCht = ws.ChartObjects.Add(Left:=180, _
Width:=270, Top:=7, Height:=210)
With oCht
.Left = POSN_LEFT
.Top = POSN_TOP + (count * 255)
.Name = sColA
With .Chart
.SetSourceData Source:=rngValue
.SeriesCollection(1).XValues = rngLabel
.ChartType = xlPie
.HasTitle = True
.SetElement msoElementChartTitleAboveChart
.ChartTitle.Text = sColA
End With
End With
count = count + 1
Else
' end of chart data
bflag = False
End If
Next
MsgBox count & " Charts created", vbInformation
End Sub
I am new to Userforms. I have created the following Userform which is called from a subroutine. The Userform picks up a range from a sheet and creates a corresponding number of textboxes and then checkboxes so as to allocate an original name with a new name.
The userform is created with the following:
Public Sub UserForm_Initialize()
'Declare variables
Dim txtBox As MSForms.TextBox
Dim comBox As MSForms.ComboBox
Dim i As Integer
Dim j As Integer
Dim n As Integer
Dim dist As Integer
Dim dstArr As Variant
Dim rng As Range
'Assign variables
Set rng = Range("Missing_MAERSK")
n = rng.Rows.Count
dist = 5
dstArr = Range("LU_Destination_Ports").Value
'Loop to add textboxes
For i = 1 To n
Set txtBox = UserForm1.Controls.Add("Forms.TextBox.1", Visible:=True)
With txtBox
.name = "txtBox" & i
.Value = rng(i)
.Height = 20
.Width = 150
.Left = 81
.Top = 30 + dist
.Font.Size = 10
End With
dist = dist + 20
Next i
'Loop to add list boxes
dist = 5
For j = 1 To n
Set comBox = UserForm1.Controls.Add("Forms.ComboBox.1", Visible:=True)
With comBox
.name = "comBox" & j
.List = dstArr
.Height = 20
.Width = 150
.Left = 315
.Top = 30 + dist
.Font.Size = 10
End With
dist = dist + 20
Next j
'Show userform
UserForm1.Show
End Sub
And then when the Replace Names button is clicked the following is ran:
Public Sub CommandButton1_Click()
'Close userform
Unload UserForm1
'This is the one
Dim cmb As MSForms.ComboBox
' Dim txt As MSForms.TextBox
Dim oldVal As String
Dim newVal As String
Dim rng As Range
Dim rng2 As Range
Dim n As Integer
Set rng = Range("MAERSK_Destin")
Set rng2 = Range("Missing_MAERSK")
n = rng2.Rows.Count
'Loop
For i = 1 To n
Set txt = Me.Controls("txtBox" & i)
Set cmb = Me.Controls("comBox" & i)
If cmb.Value <> "" Then
oldVal = txt.Value
newVal = cmb.Value
rng.Replace what:=oldVal, Replacement:=newVal
End If
Next i
End Sub
Let's say I populate Bangkok to Bangkok BMT, I get the following:
I think the issue might be with the way I call the values in the Command_Button1_Click sub.
Any advice would be appreciated.
Cheers
Figured out the problem.
According to this post: Call UserForm_Initialize from Module
a UserForm should not be initialized from outside the userform.
I was calling UserForm_Initialize() from my sub, so to rectify this I replaced it with UserForm1.Show
I am populating ActiveX control labels with a subset of Excel data in VBA. My code previously worked for the entire Excel workbook, but once I changed my code to only reference a subset of the data, the incorrect data is being entered.
Here is a snapshot of example data. In my code, Column 6= CY and Column 7 = FY. The code is currently populating my labels with the headers of Column 6 and 7 rather than the values of 'active' or 'merged' projects.
As mentioned, I am not receiving any error messages, but the correct data is not being added to my ActiveX labels. FYI... In line 31 Code1 is the name of an ActiveX label.
Private Sub CommandButton1_Click()
Dim objExcel As Excel.Application
Dim exWB As Excel.Workbook
Dim rng As Excel.Range, m, rw As Excel.Range
Dim num, TableNo, seq As Integer
Dim ctl As MSForms.Label
Dim ils As Word.InlineShape
Dim rngrow As Excel.Range
Dim active As Excel.Range
Set objExcel = New Excel.Application
TableNo = ActiveDocument.Tables.Count
num = 3
seq = 1
Set exWB = objExcel.Workbooks.Open("O:\Documents\"Database.csv")
Set rng = exWB.Sheets("Sheet1").Cells
''''Select active projects as subset
For Each rngrow In rng.Range("A1:L144")
If rngrow.Columns(8).value = "Active" Or rngrow.Columns(8).value = "Merged" Then
If active Is Nothing Then
Set active = rngrow
Else
Set active = Union(active, rngrow)
End If
End If
Next rngrow
m = objExcel.Match(ActiveDocument.Code1.Caption, active.Columns(3), 0)
'' Now, create all ActiveX FY labels and populate with FY Use
Do
Set ils = ActiveDocument.Tables(num).cell(6, 2).Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = "FY" & seq
If Not IsError(m) Then
Set rw = rng.Rows(m)
ctl.Caption = rw.Cells(7).value
Else
MsgBox "No match found"
End If
seq = seq + 1
num = num + 1
Loop Until num = TableNo + 1
'' Now, create all ActiveX CY labels and populate with CY
num = 3
seq = 1
Do
Set ils = ActiveDocument.Tables(num).cell(7, 2).Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = "CY" & seq
If Not IsError(m) Then
Set rw = rng.Rows(m)
ctl.Caption = rw.Cells(6).value
Else
MsgBox "No match found"
End If
seq = seq + 1
num = num + 1
Loop Until num = TableNo + 1
Set exWB = Nothing
End Sub
Link to my previous question below:
Using Excel data to create Word Doc caption labels in VBA
This:
For Each rngrow In rng.Range("A1:L144")
will be interpreted as
For Each rngrow In rng.Range("A1:L144").Cells
so your loop will be A1, B1, C1, ... L1 then A2, B2 etc.
It seems like you meant it to be:
For Each rngrow In rng.Range("A1:L144").Rows
so rngRow will be A1:L1, then A2:L2, etc.
EDIT - You can't refer to active using something like MsgBox(active.Range ("A2")), since it's a multi-area range.
Try this for example -
For Each rw in active.Rows
debug.print "Row:" & rw.Row, rw.cells(8).value
Next rw
EDIT2: try this instead. Untested but I think it should work OK
Private Sub CommandButton1_Click()
Dim objExcel As Excel.Application
Dim exWB As Excel.Workbook
Dim data, r As Long, resRow As Long, seq As Long, num As Long
Dim doc As Document
'get the Excel data as a 2D array
Set objExcel = New Excel.Application
Set exWB = objExcel.Workbooks.Open("O:\Documents\Database.csv")
data = exWB.Sheets("Sheet1").Range("A1:L144").Value '>> 2D array
exWB.Close False
objExcel.Quit
resRow = 0
'find the first matching row, if any
For r = 1 To UBound(data, 1)
If (data(r, 8) = "Active" Or data(r, 8) = "Merged") And _
data(r, 3) = doc.Code1.Caption Then
resRow = r 'this is the row we want
Exit Sub 'done looking
End If
Next r
Set doc = ActiveDocument
seq = 1
For num = 3 To doc.Tables.Count
With doc.Tables(num)
AddLabel .Cell(6, 2), "FY" & seq, IIf(resRow > 0, data(resRow, 7), "Not found")
AddLabel .Cell(7, 2), "CY" & seq, IIf(resRow > 0, data(resRow, 6), "Not found")
End With
seq = seq + 1
Next num
End Sub
'add a label to a cell, set its name and caption
Sub AddLabel(theCell As Cell, theName As String, theCaption As String)
Dim ils As InlineShape, ctl As MSForms.Label
Set ils = theCell.Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
Set ctl = ils.OLEFormat.Object
ctl.Name = theName
ctl.Caption = theCaption
End Sub