I get the icons for popup menus with two different codes. Why are they different if they have the same FaceID?
Not only the type of icons (one type Excel 2003 and another Excel 365) There are also different icons, as we can be seen in the image.
What code should I use in my popup menu to get the Excel 365 style?
I create my popup menu with this code and I can't get the Excel 365 icon:
With Application.CommandBars.Add(Name:=gsMENUNOTES, _
Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
With .Controls.Add(Type:=msoControlButton)
.Caption = "New note"
.OnAction = "NewNote"
.FaceId = 4385
End With
End With
This is the code to get the icons (Excel 365 type) on the Ribbon (https://stackoverflow.com/a/18364215/11185212)
Option Explicit
Const APP_NAME = "FaceIDs (Browser)"
' The number of icons to be displayed in a set.
Const ICON_SET = 30
Sub BarOpen()
Dim xBar As CommandBar
Dim xBarPop As CommandBarPopup
Dim bCreatedNew As Boolean
Dim n As Integer, m As Integer
Dim k As Integer
On Error Resume Next
' Try to get a reference to the 'FaceID Browser' toolbar if it exists and delete it:
Set xBar = CommandBars(APP_NAME)
On Error GoTo 0
If Not xBar Is Nothing Then
xBar.Delete
Set xBar = Nothing
End If
Set xBar = CommandBars.Add(Name:=APP_NAME, Temporary:=True) ', Position:=msoBarLeft
With xBar
.Visible = True
'.Width = 80
For k = 0 To 4 ' 5 dropdowns, each for about 1000 FaceIDs
Set xBarPop = .Controls.Add(Type:=msoControlPopup) ', Before:=1
With xBarPop
.BeginGroup = True
If k = 0 Then
.Caption = "Face IDs " & 1 + 1000 * k & " ... "
Else
.Caption = 1 + 1000 * k & " ... "
End If
n = 1
Do
With .Controls.Add(Type:=msoControlPopup) '34 items * 30 items = 1020 faceIDs
.Caption = 1000 * k + n & " ... " & 1000 * k + n + ICON_SET - 1
For m = 0 To ICON_SET - 1
With .Controls.Add(Type:=msoControlButton) '
.Caption = "ID=" & 1000 * k + n + m
.FaceId = 1000 * k + n + m
End With
Next m
End With
n = n + ICON_SET
Loop While n < 1000 ' or 1020, some overlapp
End With
Next k
End With 'xBar
End Sub
And this is the code to get the icons (Excel 2003 type) on the sheet (https://www.mrexcel.com/board/threads/face-id-in-column-with-their-names-in-excel-sheet-using-vba.567230/)
Option Explicit
Sub exa()
Dim CB As CommandBar
Dim ctl As CommandBarButton
Dim strCBName As String
Dim wbTemp As Workbook
Dim wks As Worksheet
Dim rngInput As Range
Dim i As Long
Application.ScreenUpdating = False
Set wbTemp = Workbooks.Add(xlWBATWorksheet)
wbTemp.SaveAs ThisWorkbook.Path & "\FaceID.xlsx"
Dim NID As Long
Dim NSheet As Long
For NSheet = 1 To 5
'// Add a temp commandbar, make it a popup (which we won't show); add a temp control //
Set CB = CommandBars.Add(Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
Set ctl = CB.Controls.Add(Type:=msoControlButton, Temporary:=True)
strCBName = CB.Name
Set wks = wbTemp.Worksheets(NSheet)
Dim vlFrom As Long
vlFrom = ((NSheet - 1) * 50 * 20) + 1
Dim vlTo As Long
vlTo = NSheet * 50 * 20
wks.Name = "F.ID " & vlFrom & "-" & vlTo
Dim Col As Integer
For Col = 2 To 40 Step 2
Dim LCol As String
LCol = Split(wks.Cells(1, Col).Address, "$")(1)
Set rngInput = wks.Range(LCol & ":" & LCol)
rngInput.Offset(, -1).ColumnWidth = 3
rngInput.ColumnWidth = 8
rngInput.HorizontalAlignment = xlRight
On Error Resume Next
For i = 1 To 50
NID = NID + 1
ctl.FaceId = NID
ctl.CopyFace
rngInput.Cells(i).PasteSpecial
rngInput.Cells(i).Value = NID
Next i
Next Col
'// just so the last image pasted doesn't stay selected//
Application.GoTo wks.Cells(1, 1)
wbTemp.Sheets.Add After:=wbTemp.Sheets(wbTemp.Sheets.Count)
'Debug.Print NSheet
'DoEvents
'// Kill the temp cbar and ctrl //
Set CB = CommandBars(strCBName)
On Error GoTo 0
If Not CB Is Nothing Then
CB.Delete
Else
MsgBox "ACK! I lost a toolbar!", 0, vbNullString
End If
Next NSheet
wbTemp.Save
End Sub
Related
I need the expert help in VBA Excel code. I need to find the number of duplicate record (AlertToString) for particular device serial number from the source sheet serial number and paste it to the other newly created output sheet by using VBA Macro.
Example (Source sheet):
Expected (Output Sheet with repeat Alert count) :
Source code as below :
Sub Alert700Count()
Dim AlertSource_Sh As Worksheet
Dim AlertOutput_Sh As Worksheet
'Insert a New Blank Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("AlertOutput").Delete
Sheets.Add.Name = "AlertOutput"
Application.DisplayAlerts = True
Set AlertSource_Sh = ThisWorkbook.Sheets("SourceSheet")
Set AlertOutput_Sh = ThisWorkbook.Sheets("AlertOutput")
AlertOutput_Sh.Cells(1, 1) = "Serial No"
AlertOutput_Sh.Cells(1, 2) = "A92"
AlertOutput_Sh.Cells(1, 3) = "A95"
AlertOutput_Sh.Cells(1, 4) = "A98"
For Each sh In ActiveWorkbook.Worksheets
With sh.Range("A1:D1")
.Font.Bold = True
.WrapText = True
.CellWidth = 35
.Selection.Font.ColorIndex = 49
.Weight = xlMedium
.LineStyle = xlDash
End With
Next sh
AlertOutput_Sh.Range("A1:D1").Borders.Color = RGB(10, 201, 88)
AlertOutput_Sh.Columns("A:D").ColumnWidth = 12
AlertOutput_Sh.Range("A1:D1").Font.Color = rgbBlueViolet
AlertOutput_Sh.Range("A1:D1").Interior.Color = vbYellow
AlertOutput_Sh.Range("A1:D1").HorizontalAlignment = xlCenter
AlertOutput_Sh.Range("A1:D1").VerticalAlignment = xlTop
' Search the duplicate record and paste in output sheet
Dim A92Count As Long
A92Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A92")
AlertOutput_Sh.Cells(2, 2) = A92Count
Dim A95Count As Long
A95Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A95")
AlertOutput_Sh.Cells(2, 3) = A92Count
Dim A98Count As Long
A98Count = Application.CountIf(AlertSource_Sh.Range("D:D"), "A98")
AlertOutput_Sh.Cells(2, 4) = A98Count
End Sub
Current Output :
Use Dictionaries to build lists of unique values and an array to hold the counts.
Option Explicit
Sub Alert700Count()
Dim wsData As Worksheet, wsOut As Worksheet
Dim dictSerNo As Object, dictAlert As Object
Dim arData, arOut, k, rngOut As Range
Dim lastrow As Long, i As Long
Dim serNo As String, alert As String
Dim r As Long, c As Long, t0 As Single: t0 = Timer
Set dictSerNo = CreateObject("Scripting.Dictionary")
Set dictAlert = CreateObject("Scripting.Dictionary")
On Error Resume Next
Application.DisplayAlerts = False
Sheets("AlertOutput").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Sheets.Add.Name = "AlertOutput"
Set wsOut = Sheets("AlertOutput")
Set wsData = Sheets("SourceSheet")
r = 1: c = 1
With wsData
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
arData = .Range("A1:D" & lastrow).Value2
' get unique serno and alert
For i = 2 To lastrow
serNo = arData(i, 1)
alert = arData(i, 4)
If dictSerNo.exists(serNo) Then
ElseIf Len(serNo) > 0 Then
r = r + 1
dictSerNo.Add serNo, r
End If
If dictAlert.exists(alert) Then
ElseIf Len(alert) > 0 Then
c = c + 1
dictAlert.Add alert, c
End If
Next
' rescan for counts
ReDim arOut(1 To r, 1 To c)
For i = 2 To lastrow
r = dictSerNo(CStr(arData(i, 1)))
c = dictAlert(CStr(arData(i, 4)))
arOut(r, c) = arOut(r, c) + 1
Next
End With
' add headers
arOut(1, 1) = "Serial No"
' sernos and alerts
For Each k In dictSerNo
arOut(dictSerNo(k), 1) = k
Next
For Each k In dictAlert
arOut(1, dictAlert(k)) = k
Next
' output counts
With wsOut
Set rngOut = .Range("A1").Resize(UBound(arOut), UBound(arOut, 2))
rngOut.Value2 = arOut
rngOut.Replace "", 0
.ListObjects.Add(xlSrcRange, rngOut, , xlYes).Name = "Table1"
.Range("A1").AutoFilter
.Range("A1").Select
End With
MsgBox "Done", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
I have an Excel file for label template with 6,300 items (each item has a parent ID which matches the picture name that suits the child item).
I found code that will run all the way through without an error (when items are missing for example).
However when share the item it has the pictures saved as a link instead of a picture, and whoever receive that file will have a broken link message.
Sub Picture()
Dim pictname As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long
lastrow = Worksheets("sheet2").Range("b1").CurrentRegion.Rows.Count
x = 2
For x = 2 To lastrow
On Error GoTo errhandler:
Set pastehere = Cells(x, 1)
pasterow = pastehere.Row
Cells(pasterow, 1).Select 'This is where picture will be inserted
pictname = Cells(x, 3) 'This is the picture name
ActiveSheet.Pictures.Insert("C:\Users\BennyCohen\Pictures\Catalogue pics\" & pictname & ".jpg").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pasterow, 1).Left
.Top = Cells(pasterow, 1).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 140
.ShapeRange.Width = 80
.ShapeRange.Rotation = 0#
.linktofile = msoFalse
.savewithdocument = msoCTrue
End With
Next
errhandler:
Range("A" & x).Value = "Review"
Resume Next
End Sub
linktofile and savewithdocument are not picture properties and the error is masked by the Resume Next in the errhandler, see here. Use Shapes.addPicture().
Sub Picture()
Const FOLDER = "C:\Users\BennyCohen\Pictures\Catalogue pics\"
Dim wb As Workbook, ws As Worksheet
Dim lastrow As Long, r As Long, pictname As String
Dim n As Long, m As Long
Set wb = ActiveWorkbook ' or ThisWorkbook
Set ws = wb.Sheets("Sheet2")
lastrow = ws.Range("B1").CurrentRegion.Rows.Count
For r = 2 To lastrow
pictname = FOLDER & ws.Cells(r, 3) & ".jpg" 'This is the picture name
' check file exists
If Len(Dir(pictname)) > 0 Then
With ws.Shapes.AddPicture(pictname, _
linktofile:=msoFalse, savewithdocument:=msoTrue, _
Left:=ws.Cells(r, 1).Left, _
Top:=ws.Cells(r, 1).Top, _
Height:=140, Width:=80)
.LockAspectRatio = msoFalse
.Rotation = 0#
End With
n = n + 1
Else
ws.Cells(r, "A") = "Review"
m = m + 1
End If
Next
MsgBox n & " Pictures inserted " & _
m & " Pictures to review", vbInformation
End Sub
I'm trying to populate a form from another table. I have an identifier (formNumber). The loop's purpose is the find all the rows in the table with the same formNumber, then list the details in a form.
Problem encountered is in the fields using startTableRow, startSubdesc1, startSubdesc2, startRemark. I dont know when they are all repeating the same values, that have already been inputted. An item should only appear once.
Dim wsCurrent As Worksheet, _
loTable1 As ListObject, _
lcColumns As ListColumns, _
lrCurrent As ListRow
Set wsCurrent = Worksheets("Expenses")
Set loTable1 = wsCurrent.ListObjects("Expenses")
Set lcColumns = loTable1.ListColumns
'Loop through and find new entries which haven't been form'd yet
For x = 1 To loTable1.ListRows.Count
Set lrCurrent = loTable1.ListRows(x)
If lrCurrent.Range(1, lcColumns("form sent?").Index) = "" And _
lrCurrent.Range(1, lcColumns("form #").Index) <> "" Then
formNumber = lrCurrent.Range(1, lcColumns("form #").Index).Value
'Set first lines on the form
Worksheets("form").Cells(10, 10).Value = formNumber
'Loop through the Expense sheet and as long as the form number doesn't _
'change, write it to the table on the form
startTableRow = 20
startSubdesc1 = 21
startSubdesc2 = 22
startRemark = 54
Do While lrCurrent.Range(1, lcColumns("form #").Index).Value = formNumber
expensesDate = lrCurrent.Range(1, lcColumns("Date").Index).Value
expensesItem = lrCurrent.Range(1, lcColumns("Description").Index).Value
expensesSubdesc1 = lrCurrent.Range(1, lcColumns("Sub-description 1").Index).Value
expensesSubdesc2 = lrCurrent.Range(1, lcColumns("Sub-description 2").Index).Value
expensesRemarks = lrCurrent.Range(1, lcColumns("Remarks").Index).Value
**Worksheets("form").Cells(startTableRow, 5) = expensesItem
Worksheets("form").Cells(startSubdesc1, 5) = expensesSubdesc1
Worksheets("form").Cells(startSubdesc2, 5) = expensesSubdesc2
Worksheets("form").Cells(startRemark, 3) = expensesRemarks
Worksheets("form").Cells(12, 10) = expensesDate**
lrCurrent.Range(1, lcColumns("form sent?").Index).Value = "Yes"
x = x + 1
startTableRow = startTableRow + 3
startSubdesc1 = startSubdesc1 + 3
startSubdesc2 = startSubdesc2 + 3
startRemark = startRemark + 1
Loop
'Need to subtract one from x to loop through the row again
x = x - 1
'Clear data in table on form
For t = 20 To 45
Worksheets("form").Cells(t, 3).Value = ""
Worksheets("form").Cells(t, 5).Value = ""
Next t
'Clear data in REMARK on form
For r = 54 To 57
Worksheets("form").Cells(r, 3).Value = ""
Next r
End If
Next x
End Sub
End Sub
The problem with your code is in the while loop the lrCurrent does not change. after x = x +1 you need to set
lrCurrent = loTable1.ListRows(x) IF x <= loTable1.ListRows.Count
Also then need to protect against running past the end of table by adding another condition
And x <= loTable1.ListRows.Count
to the Do While line at the start.
Here is an example with fewer variables by using .offset
Sub FillForm()
Dim wb As Workbook, ws As Worksheet, wsForm As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Expenses")
Set wsForm = wb.Sheets("form")
Dim tbl As ListObject
Set tbl = ws.ListObjects("Expenses")
' create look up for column names
Dim ColNum As New Collection
Dim cell As Range, ix As Integer
For Each cell In tbl.HeaderRowRange
ix = ix + 1
ColNum.add ix, cell.Value
Debug.Print cell.Value
Next
' scan table for not sent items
Dim sFormNo As String, rec As Range
Dim iCount As Integer ' count of lnes with same form no
Dim bSearch As Boolean, iSearch As Integer
Dim iRow As Integer
bSearch = False ' search for matching form no
With tbl
For iRow = 1 To .ListRows.Count
Set rec = .ListRows(iRow).Range
If rec(ColNum("form #")) <> "" _
And rec(ColNum("form sent?")) = "" Then
sFormNo = rec(1)
wsForm.Range("J10") = rec(ColNum("form #"))
wsForm.Range("J12") = rec(ColNum("Date"))
bSearch = True
End If
' search rest of table for more records
If bSearch Then
'Clear data in table on form
'wsForm.Range("C20:C45").ClearContents ' required ?
wsForm.Range("E20:C45").ClearContents
wsForm.Range("C54:C57").ClearContents
iCount = 0
' search from existing row down to end
For iSearch = iRow To .ListRows.Count
Set rec = .ListRows(iSearch).Range
' check match
If rec(ColNum("form #")) = sFormNo _
And rec(ColNum("form sent?")) = "" Then
' fill in form
With wsForm.Range("E20").Offset(3 * iCount, 0)
.Offset(0, 0) = rec(ColNum("Description"))
.Offset(1, 0) = rec(ColNum("Sub-description 1"))
.Offset(2, 0) = rec(ColNum("Sub-Description 2"))
End With
wsForm.Range("C54").Offset(iCount, 0) = rec(ColNum("Remarks"))
' update form sent column
rec(ColNum("form sent?")) = "Yes"
iCount = iCount + 1
Debug.Print "Search for " & sFormNo, rec(ColNum("form #")), iCount, iSearch
End If
Next
wsForm.Activate
wsForm.Range("A20").Select
MsgBox iCount & " lines added", vbInformation, "Completed " & sFormNo
bSearch = False
End If
Next
End With
MsgBox "Ended", vbInformation
End Sub
I generated radio buttons with the help of the answer to How to set an automatically generated radio button to true in VBA?.
My requirement is to set the automatically generated Option button to 'True' when there is a value x in another sheet.
Figure 1: The source to check the value.
Figure 2: The sheet to which the Mark x should be reflected as True.
The radio buttons that are generated are as Indexed as OB2_2 for the option button in 2 row and 2 column.
Here is the code
Private Sub AddOptionButtons(ByRef TargetRange As Range)
Dim m As Variant
m = Sheets("ALLO").Range("D23").Value + 1
Sheets("Final").Range("A2:A" & m).Copy Destination:=Sheets("Int_Result").Range("A2:A" & m)
Dim oCell As Range
For Each oCell In TargetRange
oCell.RowHeight = 20
oCell.ColumnWidth = 6
Dim oOptionButton As OLEObject
Set oOptionButton = TargetRange.Worksheet.OLEObjects.Add(ClassType:="Forms.OptionButton.1", Left:=oCell.Left + 1, Top:=oCell.Top + 1, Width:=15, Height:=18)
oOptionButton.Name = "OB" & oCell.row & "_" & oCell.Column
oOptionButton.Object.GroupName = "grp" & oCell.Top
Next
Call OB2_Click(oCell)
End Sub
Sub OB2_Click(oCell)
Dim col, ro, m As Variant
Dim Shap As Shape
m = Sheets("ALLO").Range("D23").Value + 1
For Each Shap In Sheets("Int_Result").Shapes
For ro = 2 To m Step 1
For col = 1 To 13 Step 1
If Sheets("Final").Cells(ro, col).Value = "" Then
Sheets("Int_Result").Shapes(ro, col).ControlFormat.Value = False
Else
Sheets("Int_Result").Shapes(ro, col).ControlFormat.Value = True
End If
Next col
Next ro
Next Shap
End Sub
I get
"Object variable or With block variable not set" or "Wrong number of arguments or Invalid Property assignment".
on this line
Sheets("Int_Result").Shapes(ro, col).ControlFormat.Value = False
How do I access the automatically generated radio buttons?
You need to use
Sheets("Int_Result").OLEObjects("OB2_2").Object.Value = True
Set loop not for shapes, but normal to last row and last column.
So for example:
Dim oCell As Range
Dim LastCell As Range
For Each oCell In TargetRange
oCell.RowHeight = 20
oCell.ColumnWidth = 6
Dim oOptionButton As OLEObject
Set oOptionButton = TargetRange.Worksheet.OLEObjects.Add(ClassType:="Forms.OptionButton.1", Left:=oCell.Left + 1, Top:=oCell.Top + 1, Width:=15, Height:=18)
oOptionButton.Name = "OB" & oCell.Row & "_" & oCell.Column
oOptionButton.Object.GroupName = "grp" & oCell.Top
Set LastCell = oCell
Next
Call OB2_Click(LastCell)
Sub OB2_Click(oCell as Range)
Dim col As Long, ro As Long
dim m as long, k as long
col = oCell.Column
ro = oCell.Row
For m = 2 to ro
For k = 2 to col
If Sheets("Final").Cells(m, k).Value = "" Then
Sheets("Int_Result").OLEObjects("OB" & m & "_" & k).Object.Value = False
Else
Sheets("Int_Result").OLEObjects("OB" & m & "_" & k).Object.Value = True
End If
Next k
Next m
End sub
/This code is for a command button in Userform in excel VBA/
Function CreateLabel(ByVal b As Integer, ByVal c As Long, ByVal d As String)
Application.DisplayAlerts = False
Dim i As Long
i = i + b
For labelCounter = 1 To i
On Error GoTo Count
Set theLabel = UserForm3.Controls.Add("Forms.Label.1", "Cart" & labelCounter, True)
With theLabel
.Caption = d
.Left = 10
.Width = 50
.Top = 10 * labelCounter
End With
Set theLabel2 = UserForm3.Controls.Add("Forms.Label.1", "Cart" & labelCounter, True)
With theLabel2
.Caption = c
.Left = 70
.Width = 50
.Top = 10 * labelCounter
End With
Count:
Next labelCounter
UserForm3.TextBox1.Value = UserForm3.TextBox1.Value + c
h = Sheet1.TextBox1.Value
Dim f As Workbook
Set f = Workbooks.Open("C:\Users\39800\Desktop\Hexa_DB.xlsx") /*Here workbook is opened*/
l = f.Worksheets("sheet2").Select()
f.Worksheets("sheet2").UsedRange().Select
ActiveCell.SpecialCells(xlLastCell).Select
xLastRow = ActiveCell.Row
xLastCol = ActiveCell.Column
For q = 2 To xLastRow
If (Cells(q, 1).Value = h) Then
Cells(q, 2) = Format(UserForm3.TextBox1.Value, "Currency")
f.Save
f.Close /*Here it is closing my userform also*/
End If
Next q
MsgBox "You have Successfully added this item to cart"
Exit Function
End Function
Add a reference to your current workbook before you open the new one,
Dim wbkCurrent as workbook
Set wbkCurrent = ActiveWorkbook
Then after your f.Save add wbkCurrent.Activate