So my code looks like this:
Dim i As Integer
Dim labelnum As String
For i = 1 To 81
labelnum = "Label" & i
If "labelnum".Caption = Label1.Caption Then
"labelnum".BackColor = Label1.BackColor
End If
Next i
I want to loop through 81 labels to check to see if the caption in that one is the same as the one I have selected. Is there something else I can put where it says "labelnum"?
I'm practicing and trying to make sudoku through VBA. I want to highlight the box I have selected and highlight all other squares on the board that have the same number.
Thanks!
In a Worksheet, a Label is a Shape Object, so you can use the Shapes collection:
Dim i As Integer
Dim shpLabel As Shape
For i = 1 To 81
Set shpLabel = Sheet1.Shapes("labelnum" & i)
If shpLabel.Caption = Label1.Caption Then
shpLabel.BackColor = Label1.BackColor
End If
Set shpLabel = Nothing
Next i
In a UserForm, a Label is a Control Object, so you can use the Controls collection:
Dim i As Integer
Dim ctrlLabel As Control
For i = 1 To 81
Set ctrlLabel = Me.Controls("labelnum" & i)
If ctrlLabel.Caption = Label1.Caption Then
ctrlLabel.BackColor = Label1.BackColor
End If
Set ctrlLabel = Nothing
Next i
Related
I'm making a Userform in VBA where I have Text Box's where I can search items. I have about 30 Text Box's so I want to cut down the code using a loop instead of copy and pasting the same code 30 times.
Problem: I don't know how to loop through a public variable
Public Variable: Public oEventHandler(Number) As New clsSearchableDropdown
oEventHandler would go from 1 to 30 (e.g oEventHandler2,oEventHandler3...oEventHandler30)
clsSearchableDropdown is the Class Module for the search feature
Text Box: TextBox(Number)
ListBox: ListBox(Number)
Here is the original code (No Issue Just to Compare):
With oEventHandler1
' Attach the textbox and listbox to the class
Set .SearchListBox = Me.ListBox1
Set .SearchTextBox = Me.TextBox1
' Default settings
.MaxRows = 10
.ShowAllMatches = True
.CompareMethod = vbTextCompare
.WindowsVersion = False
End With
This is what I'm trying to do:
Dim i As Integer
for i = 1 to 30
With Me.Controls.Item("oEventHandler" & i)
' Attach the textbox and listbox to the class
Set .SearchListBox = Me.Controls.Item("ListBox" & i)
Set .SearchTextBox = Me.Controls.Item("TextBox" & i)
' Default settings
.MaxRows = 10
.ShowAllMatches = True
.CompareMethod = vbTextCompare
.WindowsVersion = False
End With
Next i
I know that oEventHandler is not a control but is there a similar code I can use to loop through a public variable?
Here is the code that worked for me:
' Make a New Collection
Dim coll As New Collection
' Add all Public Variables to Collection (n = Number 1 to 30)
coll.Add uQuote.oEventHandler(n)
(e.g oEventHandler1, oEventHandler2... oEventHandler30)
Dim i As Integer
for i = 1 to 30
With coll(i)
' Attach the textbox and listbox to the class
Set .SearchListBox = Me.Controls.Item("ListBox" & i)
Set .SearchTextBox = Me.Controls.Item("TextBox" & i)
' Default settings
.MaxRows = 10
.ShowAllMatches = True
.CompareMethod = vbTextCompare
.WindowsVersion = False
End With
Next i
If I understand you correctly, in the userform you have 30 Textboxes and 30 Listboxes, where each Textbox(N) is to search the value in the Listbox(N) located under that TextBox(N). So it looks something like this :
On the left side is TextBox01, under TextBox01 is ListBox01
On the right side is TextBox02, under TextBox02 is ListBox02
If the animation is similar with your expectation....
Preparation :
Make a named range (as many as needed) with something like List01, List02, List03, and so on for the value to populate each ListBox.
Name each ListBox with something like ListBox01, ListBox02, and so on.
Name each TextBox with something like TextBox01, TextBox02, and so on.
In the Userform module:
Dim MyTextBoxes As Collection
Private Sub UserForm_Initialize()
'populate the ListBoxes with value in a named range
Dim LBname As String: Dim RGname As String: Dim i As Integer
For i = 1 To 2
LBname = "ListBox" & Format(i, "00")
RGname = "List" & Format(i, "00")
Controls(LBname).List = Application.Transpose(Range(RGname))
Next i
'add each TextBox to class
Set MyTextBoxes = New Collection
For Each ctl In Me.Controls
Set TextBoxClass = New Class1
If TypeName(ctl) = "TextBox" And InStr(ctl.Name, "TextBox") Then Set TextBoxClass.obj = ctl
MyTextBoxes.Add TextBoxClass
Next
End Sub
In the Class Module named Class1:
Private WithEvents tb As MSForms.TextBox
Property Set obj(t As MSForms.TextBox)
Set tb = t
End Property
Private Sub tb_Change()
Dim idx As String: Dim LBname As String: Dim arr
idx = Right(tb.Name, 2)
LBname = "ListBox" & idx
arr = Application.Transpose(Range("List" & idx))
With Userform1.Controls(LBname)
If tb.text = "" Then
.Clear
.List = arr
Else
.Clear
For i = LBound(arr, 1) To UBound(arr, 1)
If LCase(arr(i)) Like "*" & LCase(tb.value) & "*" Then .AddItem arr(i)
Next i
End If
End With
End Sub
If in your userform you have another textbox which not to use as a search of the items in respective listbox, then maybe don't name the textbox with "TextBox" but something else, for example "blablabla".
if your existing textbox and listbox already named something like ListBox1, ListBox2, ListBox3 and so on, TextBox1, TextBox2, TextBox3 and so on... then name the named range like List1, List2, List3 and so on. In the class module, change the code for idx using the replace method, something like idx = replace(tb.name,"TextBox",""). Also in the Userform module for LBname and RGname use the replace method.
Because I'm limited in English language, I'm sorry I can't detail the code for further explanation.
I'm trying to link shape data field from external data like excel.
As #JohnGoldsmith suggested I used DropLinked but "I'm getting object name not found" error.
My main agenda is drop multiple shapes on drawing with shape data field "Name", then fill all the shape data field using external data in order. I also used spatial search for dropping shapes on drawing(Thanks to #Surrogate). By the way I'm using Visio Professional 2019.
It's often a good plan to separate chained members so you can identify whether (as #Paul points out) you're having a problem getting to the stencil or the master.
Following is a modified example of link shapes to data. I've ditched all of the spatial search stuff as I think that's a separate issue. If you still have trouble with that I would ask another question and narrow your sample code to not include the data linking part - ie just drop shapes and try and change their position. Bear in mind there's also Page.Layout and Selection.Layout
I think you've got the adding the DataRecordsets in the other linked question, so this example makes the following assumptions:
You have a drawing document open
You have the "Basic Shapes" stencil open (note my version is metric "_M")
You have a DataRecordset applied to the document named "AllNames"
The above record set has a column named "Name" that contains the data you want to link
Public Sub ModifiedDropLinked_Example()
Const RECORDSET_NAME = "AllNames"
Const COL_NAME = "Name"
Const STENCIL_NAME = "BASIC_M.vssx"
Const MASTER_NAME = "Rectangle"
Dim vDoc As Visio.Document
Set vDoc = Application.ActiveDocument
Dim vPag As Visio.Page
Set vPag = Application.ActivePage
Dim vShp As Visio.Shape
Dim vMst As Visio.Master
Dim x As Double
Dim y As Double
Dim xOffset As Double
Dim dataRowIDs() As Long
Dim row As Long
Dim col As Long
Dim rowData As Variant
Dim recordset As Visio.DataRecordset
Dim recordsetCount As Integer
For Each recordset In vDoc.DataRecordsets
If recordset.Name = RECORDSET_NAME Then
dataRowIDs = recordset.GetDataRowIDs("")
xOffset = 2
x = 0
y = 2
Dim vStencil As Visio.Document
Set vStencil = TryFindDocument(STENCIL_NAME)
If Not vStencil Is Nothing Then
Set vMst = TryFindMaster(vStencil, MASTER_NAME)
If Not vMst Is Nothing Then
For row = LBound(dataRowIDs) + 1 To UBound(dataRowIDs) + 1
rowData = recordset.GetRowData(row)
For col = LBound(rowData) To UBound(rowData)
Set vShp = vPag.DropLinked(vMst, x + (xOffset * row), y, recordset.ID, row, False)
Debug.Print "Linked shape ID " & vShp.ID & " to row " & row & " (" & rowData(col) & ")"
Next col
Next row
Else
Debug.Print "Unable to find master '" & MASTER_NAME & "'"
End If
Else
Debug.Print "Unable to find stencil '" & STENCIL_NAME & "'"
End If
Else
Debug.Print "Unable to find DataRecordset '" & RECORDSET_NAME & "'"
End If
Next
End Sub
Private Function TryFindDocument(docName As String) As Visio.Document
Dim vDoc As Visio.Document
For Each vDoc In Application.Documents
If StrComp(vDoc.Name, docName, vbTextCompare) = 0 Then
Set TryFindDocument = vDoc
Exit Function
End If
Next
Set TryFindDocument = Nothing
End Function
Private Function TryFindMaster(ByRef vDoc As Visio.Document, mstNameU As String) As Visio.Master
Dim vMst As Visio.Master
For Each vMst In vDoc.Masters
If StrComp(vMst.NameU, mstNameU, vbTextCompare) = 0 Then
Set TryFindMaster = vMst
Exit Function
End If
Next
Set TryFindMaster = Nothing
End Function
The above code drops six shapes onto the page and adds a Shape Data row (Prop._VisDM_Name) with the corresponding data value. If you want the name text to appear in the shape then you would normally modify the master with an inserted field in the shape's text. (If you get stuck with this part then ask another question.)
One last point is that this example loops through the DataRecordset rows dropping a shape for each one, but there is also a Page.DropManyLinkedU method that allows you to this en masse.
Program: Excel 2016.
I have a sheet with a lot of shapes. Each of them has its own specific name and most of them are label. I want to change their caption property, but i can't find a way but calling them one by one like this:
LblLabel_1.Caption = ...
LblLabel_2.Caption = ...
LblLabel_3.Caption = ...
Instead i was looking for something like this:
For BytCounter01 = 1 to 255
Shapes("LblLabel_" & BytCounter01).Caption = ...
Next
This one will result in error 438, basically saying Caption is not avaiable for this object. It still target the object, since this code:
Debug.print Shapes("LblLabel_" & BytCounter01).Name
will return me its name.
Looking for a solution:
-i've tried Controls("LblLabel_" & BytCounter01) instead of Shapes("LblLabel_" & BytCounter01) but it won't work since Controls is only for userforms, not for sheets;
-i've tried Shapes("LblLabel_" & BytCounter01).TextFrame.Characters.Text but it returns error 438 again;
-since the label is a part of a group, i've tried both
Shapes("ShpGroupOfShapes01").GroupItems(ShpShapeIndex).Caption
and
Shapes("ShpGroupOfShapes01").GroupItems(ShpShapeIndex).TextFrame.Characters.Text
but got 438 again.
Is there really no way to easily target a specific label on a sheet and change his caption?
Thank you.
EDIT: thanks to Excelosaurus, the problem is solved. Since my labels are ActiveX Controls i have to use something like this:
For BytCounter01 = 1 to 255
Shapes("LblLabel_" & BytCounter01)OLEFormat.Object.Object.Caption = ...
Next
You can check his response and comments for more details. Thanks again Excelosaurus!
To change the textual content of a shape, use .TextFrame2.TextRange.Text as shown below:
shtShapes.Shapes(sShapeName).TextFrame2.TextRange.Text = sShapeCaption
where shtShapes is the name of your worksheet's object as seen from the Visual Basic Editor in the Project Explorer,
sShapeName is a string variable containing the name of the target shape, and
sShapeCaptionis a string variable containing the desired caption.
A code example follows. I've thrown in a function to check for a shape's existence on a worksheet, by name.
Option Explicit
Public Sub SetLabelCaptions()
Dim bCounter As Byte
Dim sShapeName As String
Dim sShapeCaption As String
For bCounter = 1 To 255
sShapeName = "LblLabel_" & CStr(bCounter)
If ShapeExists(shtMyShapes, sShapeName) Then
sShapeCaption = "Hello World " & CStr(bCounter)
shtMyShapes.Shapes(sShapeName).TextFrame2.TextRange.Text = sShapeCaption
Else
Exit For
End If
Next
End Sub
Public Function ShapeExists(ByVal pshtHost As Excel.Worksheet, ByVal psShapeName As String) As Boolean
Dim boolResult As Boolean
Dim shpTest As Excel.Shape
On Error Resume Next
Set shpTest = pshtHost.Shapes(psShapeName)
boolResult = (Not shpTest Is Nothing)
Set shpTest = Nothing
ShapeExists = boolResult
End Function
The result should look like this:
You can't assign a Caption to a Shape. (Shapes don't have Captions). One approach is to loop over the Shapes and build a little table to tell you what to loop over next:
Sub WhatDoIHave()
Dim kolumn As String, s As Shape
Dim i As Long, r As Range
kolumn = "Z"
i = 1
For Each s In ActiveSheet.Shapes
Set r = Cells(i, kolumn)
r.Value = i
r.Offset(, 1).Value = s.Name
r.Offset(, 2).Value = s.Type
r.Offset(, 3).Value = s.TopLeftCell.Address(0, 0)
i = i + 1
Next s
End Sub
Which for my sample produced:
Seeing that I have both Forms and ActiveX (OLE) Controls, I know what to loop over next. I then refer to the Control by number and assign a Caption if appropriate.
I have a class called autoCRUD in a class module in excel 2013. From another module (a regular one) I try to call a method from this class and I get the "Object required" exception.
Here's the method:
Public Function CreateCRUDView(TipoCRUD As String) 'TipoCRUD pode ser C (Create), R (Read), U (Update), D (Delete)
Dim myForm As Object
Dim NewFrame As MSForms.Frame
Dim NewButton As MSForms.CommandButton
Dim NewListBox As MSForms.ListBox
Dim NewLabel As MSForms.Label
Dim X As Integer
Dim Line As Integer
Dim t As Integer
Dim arrLeg() As Variant
arrLeg = legenda
'This is to stop screen flashing while creating form
Application.VBE.MainWindow.Visible = False
Set myForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
'Create the User Form
With myForm
.Properties("Caption") = "New Form"
.Properties("Width") = 300
.Properties("Height") = 270
End With
'Criar labels
t = 10
For Each lbl In arrLeg
Set NewLabel = myForm.Designer.Controls.Add("Forms.label.1")
With NewLabel
.name = "lbl_" + Replace(CStr(lbl.Value), " ", "")
.t = (10 + t)
.Left = 10
.Font.Size = 8
End With
t = t + 10
Next
'Create CommandButton Create
Set NewButton = myForm.Designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.name = "cmd_1"
If UCase(TipoCRUD) = "C" Then
.Caption = "Salvar"
ElseIf UCase(TipoCRUD) = "U" Then
.Caption = "Alterar"
End If
.Accelerator = "M"
.Top = Top + 10
.Left = 200
.Width = 66
.Height = 20
.Font.Size = 8
.Font.name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
Top = Top + 10
End Function
The code from another module that calls the method is :
Public Sub Main()
Dim ac As autoCrud
Set ac = New autoCrud
ac.CreateCRUDView ("c")
End Sub
I don't get it, why am I getting this error?
Here is the code for "legenda":
Public Property Get sht() As Worksheet
Const shtName As String = "Teste1"
Set sht = ActiveWorkbook.Worksheets(shtName)
End Property
Public Property Get legenda() As Range
Const linha As Integer = 3
Const colunaI As Integer = 2
Dim colunaF As Integer
Dim i As Integer
i = colunaI
Do While sht.Cells(linha, i).Value <> ""
i = i + 1
Loop
colunaF = (i - 1)
Set legenda = sht.Range(Cells(linha, colunaI), Cells(linha, colunaF))
End Property
The lbl.Value is supposed to be a string value, the name of the label. And it comes from the spread sheet in the header of the table, teh legenda() only selects that header and the arrLeg takes the legenda as a range and transforms it in an array.
Edit:
Apparently the error occurs in the line that says: .name = "lbl_" + Replace(CStr(lbl.Value), " ", "")
As you can see, I've tried to take the spaces from the string and also ensure that it is a string, but none of it worked.
Edit 2:
I actually just use a class for organization and re-usability purposes. I take the properties and other methods and use them inside the 'createCRUDView' method, this method will then create a CRUD View, that is, create a form either to "Create", "Read" (not used since it's excel),"Update or "Delete" data entries. It basically creates forms dynamically to any table you make
VBA error 424 is object required error. So I'm now pretty sure that lbl in CStr(lbl.Value) is not an object. With your code legenda is a Range but after
Dim arrLeg() As Variant
arrLeg = legenda
arrLeg will be a variant array. This array does not contain objects. You can debug this with
For Each lbl In arrLeg
...
MsgBox TypeName(lbl)
...
Next
So you should use CStr(lbl).
And
Set legenda = sht.Range(Cells(linha, colunaI), Cells(linha, colunaF))
will only work while the "Teste1" sheet is the ActiveSheet because Cells(linha, colunaI) is not explicit assigned to a sheet so the ActiveSheet will be supposed.
Set legenda = sht.Range(sht.Cells(linha, colunaI), sht.Cells(linha, colunaF))
will be better.
I want to export data from Excel to a pdf-Form using vba.
I used this approach:
https://forums.adobe.com/thread/302309
When I copy just one field it works, but I want to copy all the fields from A1:K2 where the field titles are always in the top and the content in the rows below.
I think my problem is that I don't switch back to Excel when I am trying to copy the next value and field title. But I don't know how to do it properly.
So I would be really glad if someone could tell me.
The files could be downloaded here:
http://www.xn--frank-mller-zhb.net/Formulardings.zip
Sub Pdfdings()
Dim gApp As Acrobat.CAcroApp
Dim avdoc As Acrobat.CAcroAVDoc
Dim gPDDoc As Acrobat.CAcroPDDoc
Const DOC_FOLDER As String = "C:\Users\Frank\Documents"
Dim x As Boolean
Set gApp = CreateObject("AcroExch.App")
Set gPDDoc = CreateObject("AcroExch.PDDoc")
Set avdoc = CreateObject("AcroExch.AVDoc")
'Hides Acrobat - So Far So Good
'gApp.Hide
Dim FormApp As AFORMAUTLib.AFormApp
Dim AcroForm As AFORMAUTLib.Fields
Dim Field As AFORMAUTLib.Field
Dim z, i, j, n As Integer
Dim wksTab1 As Worksheet
Dim Feld, Inhalt As String
Set wksTab1 = Sheets("Tabelle2")
'Open PDF that I choose. Acrobat still has not flashed on my screen
j = 1
i = 2
While i < 3
x = avdoc.Open(DOC_FOLDER & "\formular_ve01a.pdf", "temp")
'Acrobat Now Pops up on my screen. However, I get an error without this line. avdoc.Show works the same as Maximize it seems.
avdoc.Maximize (1)
'Hides it again, right after it opens. This creates a flash
'gApp.Hide
Set FormApp = CreateObject("AFormAut.App")
While j < 39
'If the Maximize line is not there, this is where I receive error about document viewer
Feld = wksTab1.Cells(1, j).Value
Inhalt = wksTab1.Cells(i, j).Value
For Each Field In FormApp.Fields
If Field.Name = Feld Then
Field.Value = Inhalt
End If
Next
j = j + 1
Wend
Dim sDoc
Set sDoc = avdoc.GetPDDoc
saveOk = sDoc.Save(1, DOC_FOLDER & "\OK_Formular" & wksTab1.Cells(1, 1).Value & ".pdf")
avdoc.Close (1)
gApp.Exit
i = i + 1
Wend
End Sub
Set A1:K2 as your print range
Set your printer to a PDF Writer (CutePDF or PDF995 or other)
Print
solution I got by the help of another forum
<pre>While j < 39
'If the Maximize line is not there, this is where I receive error about document viewer
Feld = wksTab1.Cells(1, j).Value
Inhalt = wksTab1.Cells(i, j).Value
FormApp.Fields(Feld).Value = Inhalt
j = j + 1
Wend
Thank you everyone!