I have this code that I am using to search a range when I click the item in my listbox. I have never looped through a listbox and want to know how I add a loop to perform what I need without clicking each item in the listbox. Here is the code I am using:
Sub FindListValue()
Dim FirstAddress As String
Dim rSearch As Range 'range to search
Dim c As Range
With Sheets("PN-BINS")
Set rSearch = .Range("B1", .Range("B65536").End(xlUp))
End With
Dim i As Long
' loop through all items in ListBox1
For i = 0 To Me.ListBox1.ListCount - 1
' current string to search for
strFind = Me.ListBox1.List(i)
With rSearch
Set c = .Find(strFind, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then 'found it
c.Select
Me.ListBox1.AddItem strFind & " | " & c.Offset(0, -1).Value, Me.ListBox1.ListIndex + 1
Me.ListBox1.RemoveItem (Me.ListBox1.ListIndex)
'Exit Sub
Else: 'MsgBox strFind & " is not listed!" 'search failed
End If
End With
' the rest of your code logics goes here...
Next i
End Sub
In order to loop through all items in the ListBox1, use the following loop:
Dim i As Long
' loop through all items in ListBox1
For i = 0 To Me.ListBox1.ListCount - 1
' current string to search for
strFind = Me.ListBox1.List(i)
' the rest of your code logics goes here...
Next i
B.T.W , it's better if you define your rSearch range in the following way (without using Activate and ActiveSheet)
With Sheets("PN-BINS")
Set rSearch = .Range("B1", .Range("B65536").End(xlUp))
End With
Edit 1: Whole code
Sub FindListValue()
Dim FirstAddress As String
Dim rSearch As Range 'range to search
Dim c As Range
Dim i As Long
With Sheets("PN-BINS")
Set rSearch = .Range("B1", .Range("B65536").End(xlUp))
End With
' loop through all items in ListBox1
For i = 0 To Me.ListBox1.ListCount - 1
strFind = Me.ListBox1.List(i) ' string to look for
Set c = rSearch.Find(strFind, LookIn:=xlValues, LookAt:=xlWhole)
' current ListBox1 item is found
If Not c Is Nothing Then
Me.ListBox1.AddItem strFind & " | " & c.Offset(0, -1).Value, i + 1
Me.ListBox1.RemoveItem (i)
' ****** not sure if you want to use the line below ? ******
Exit Sub
Else
MsgBox strFind & " is not listed!" 'search failed
End If
Next i
End Sub
Related
I have no experience in Visual Basic and I am trying to add or delete columns based on a cell value while keeping the same format from the first column. I´ve seen some posts but my programming knowledge is very basic and I can´t find a way to adjust variables for it to fit into my file.
The following code seems to work for the post I read but as I said I don´t know what to change for it to work in my file:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range, ColNum As Long, TotalCol As Long, LeftFixedCol As Long
Dim Rng As Range, c As Range
Set KeyCells = Range("B1")
If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
If IsNumeric(KeyCells.Value) = False Then Exit Sub
ColNum = KeyCells.Value
If ColNum <= 0 Then Exit Sub
Set Rng = Range(Cells(3, 1), Cells(3, Columns.Count))
Set c = Rng.Find("Total") 'the find is case senseticve, Change "Total" to desired key word to find
If c Is Nothing Then Exit Sub
TotalCol = c.Column
LeftFixedCol = 2 'Column A & B for Company and ID
Dim i As Integer
If TotalCol < LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol To LeftFixedCol + ColNum
Columns(i).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(3, i).Value = "Column " & i - LeftFixedCol ' may not use this line
Next i
End If
If TotalCol > LeftFixedCol + ColNum + 1 Then ' Add column
For i = TotalCol - 1 To LeftFixedCol + ColNum + 1 Step -1
Columns(i).Delete
Next i
End If
End Sub
Is it too much to ask if somebody could please help identifying each code line or give me a more simple code to work with?
The following gif shows exactly what I am trying to do:
Thanks beforehand!
A Worksheet Change: Insert or Delete Columns
This code mustn't be copied into a standard module, e.g. Module1 as you did.
It needs to be copied into a sheet module, e.g. Sheet1, Sheet2, Sheet3 (the names not in parentheses), of the worksheet where you want this to be applied. Just double-click on the appropriate worksheet in the Project Explorer window (seen on the top-left of your screenshot), copy the code to the window that opens and exit the Visual Basic Editor.
The code runs automatically as you change the values in the target cell (B1 with this setup) i.e. you don't run anything.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
' e.g. to prevent
' "Run-time error '1004': Microsoft Excel can't insert new cells because
' it would push non-empty cells off the end of the worksheet.
' These non-empty cells might appear empty but have blank values,
' some formatting, or a formula. Delete enough rows or columns
' to make room for what you want to insert and then try again.",
' which is covered for the header row, as long there is nothing
' to the right of the total column, but not for other rows.
Const TargetCellAddress As String = "B1"
Const TotalFirstCellAddress As String = "D3"
Const TotalColumnTitle As String = "Total" ' case-insensitive
Dim TargetCell As Range
Set TargetCell = Intersect(Me.Range(TargetCellAddress), Target)
If TargetCell Is Nothing Then Exit Sub ' cell not contained in 'Target'
Dim NewTotalIndex As Variant: NewTotalIndex = TargetCell.Value
Dim isValid As Boolean ' referring to an integer greater than 0
If VarType(NewTotalIndex) = vbDouble Then ' is a number
If Int(NewTotalIndex) = NewTotalIndex Then ' is an integer
If NewTotalIndex > 0 Then ' is greater than 0
isValid = True
End If
End If
End If
If Not isValid Then Exit Sub
Dim hrrg As Range ' Header Row Range
Dim ColumnsDifference As Long
With Range(TotalFirstCellAddress)
Set hrrg = .Resize(, Me.Columns.Count - .Column + 1)
If NewTotalIndex > hrrg.Columns.Count Then Exit Sub ' too few columns
ColumnsDifference = .Column - 1
End With
Dim OldTotalIndex As Variant
OldTotalIndex = Application.Match(TotalColumnTitle, hrrg, 0)
If IsError(OldTotalIndex) Then Exit Sub ' total column title not found
Application.EnableEvents = False
Dim hAddress As String
Select Case OldTotalIndex
Case Is > NewTotalIndex ' delete columns
hrrg.Resize(, OldTotalIndex - NewTotalIndex).Offset(, NewTotalIndex _
- ColumnsDifference + 2).EntireColumn.Delete xlShiftToRight
Case Is < NewTotalIndex ' insert columns
With hrrg.Resize(, NewTotalIndex - OldTotalIndex) _
.Offset(, OldTotalIndex - 1)
' The above range becomes useless after inserting too many columns:
hAddress = .Address
.EntireColumn.Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove
End With
With Me.Range(hAddress)
.Formula = "=""Column""&COLUMN()-" & ColumnsDifference - 1
.Value = .Value
End With
Case Else ' is equal; do nothing
End Select
SafeExit:
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
I am creating a VBA Excel program where I can copy the cell value to another sheet if its corresponding checkbox is checked. I have 278 "number" entries in one column and an corresponding individual "checkboxes" in one column. But when click the checkbox, the corresponding row text is not displayed.Instead it shows only the first 5 column values. For example, If I select 5 checkboxes randomly, it shows 1,2,3,4,5 numbers are displayed in the "sheet 2" columns.
Sub Button21_Click()
Dim chkbx As CheckBox
Dim i As Integer
a = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = xlOn Then
Worksheets("sheet1").Cells(i, 1).Copy
Worksheets("sheet2").Activate
b = Worksheets("sheet2").Cells(i, 1).End(xlUp).Row
Worksheets("sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
i = i + 1
End If
Next chkbx
Next i
End Sub
This is the code I've used.
Any help would be appreciated.
An Objects Investigation
The Solution
The TopLeftCell Solution, The Solution, is based on the idea of Tim Williams suggested in the comments.
This will be in your sheet code (Sheet1).
Sub Button21_Click()
executeCheckBoxes
End Sub
The rest will be in a standard module (e.g. Module1).
Sub executeCheckBoxes()
Dim src As Worksheet ' Source Worksheet (Object)
Dim tgt As Worksheet ' Target Worksheet (Object)
Dim chkbx As CheckBox ' CheckBox (For Each Control Variable)
Dim srcLR As Long ' Source Last Row
Dim tgtER As Long ' Target Empty Row
Dim i As Long ' Source Row Counter
Set src = ThisWorkbook.Worksheets("Sheet1")
Set tgt = ThisWorkbook.Worksheets("Sheet2")
srcLR = src.Cells(src.Rows.Count, 1).End(xlUp).Row
tgtER = tgt.Cells(tgt.Rows.Count, 1).End(xlUp).Row + 1
For Each chkbx In src.CheckBoxes
If chkbx.Value = xlOn Then
' Cell Version
tgt.Cells(tgtER, 1).Value = _
src.Cells(chkbx.TopLeftCell.Row, 1).Value
' The following 2 ideas are not so good. They are running into trouble
' when adding new checkboxes if not sooner.
' Index Version
' Assuming the index of the checkbox is 1 for row 2, 2 for 3 etc.
' Adjust the "+1" as needed.
' tgt.Cells(tgtER, 1).Value = src.Cells(chkbx.Index + 1, 1).Value
' Name Version
' Assuming the name of the checkbox is "Check Box 1" for row 2,
' "Check Box 2" for 3 etc. Adjust the "+1" as needed.
' tgt.Cells(tgtER, 1).Value = src.Cells(Val(Right(chkbx.Name, _
' Len(chkbx.Name) - Len("Check Box "))) + 1, 1).Value
tgtER = tgtER + 1
Debug.Print chkbx.Name
End If
Next chkbx
End Sub
Extras
The following are codes used to help to create the two inferior solutions.
Sub deleteCB()
deleteCheckBoxes ThisWorkbook.Worksheets("Sheet1")
End Sub
' Deletes all check boxes on a worksheet.
' Note: When you delete all check boxes, the 'counter' is not reset i.e. if you
' e.g. had "Check Box 100" the next check box will be named "Check Box 101".
' But after you save and close the workbook and open it again,
' the first check box name will be "Check Box 1".
Sub deleteCheckBoxes(Sheet As Worksheet)
Sheet.CheckBoxes.Delete
End Sub
' Creates check boxes in a range.
Sub addCheckBoxes()
Const SheetName As String = "Sheet1"
Const chkRange As String = "B2:B279"
Const chkCaption As String = "Chk"
Dim chk As CheckBox, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets(SheetName)
Set rng = .Range(chkRange)
For Each cel In rng.Cells
Set chk = .CheckBoxes.Add(cel.Left, cel.Top, cel.Width, cel.Height)
With chk
.Caption = chkCaption & i
End With
i = i + 1
Next
End With
End Sub
Sub showSomeCheckBoxProperties()
Dim chk As CheckBox, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1")
For Each chk In .CheckBoxes
With chk
Debug.Print .BottomRightCell.Address, .Caption, _
.Characters.Count, .Enabled, .Index, .Name, .Placement, _
.Text, .TopLeftCell.Address, .Value, .Visible
End With
Next
End With
End Sub
Extras 2
The following is the code based on the YouTube video
Add Button to Worksheet and Assign a Macro to it -Excel Help by XLorate that helped quite a lot in answering this question.
Sub addButtons()
Dim btn As Button, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A1:A3")
For Each cel In rng.Cells
Set btn = .Buttons.Add(cel.Left, cel.Top, cel.Width, cel.Height)
With btn
.Caption = "Macro" & i
.OnAction = "Macro" & i
End With
i = i + 1
Next
End With
End Sub
The following are some other more or less helpful codes which I created while investigating objects.
Sub showSomeShapesProperties()
Dim ws As Worksheet, sh As Shape
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each sh In ws.Shapes
With sh
If sh.Type = 12 Then
Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
End If
If sh.Type = 8 Then
Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
End If
End With
Next
End Sub
Sub showSomeOleObjectProperties()
Dim ws As Worksheet, oo As OLEObject
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each oo In ws.OLEObjects
With oo
Debug.Print .Name, .OLEType, .AutoLoad, .Enabled, .Index, _
.BottomRightCell.Address
End With
Next
End Sub
Sub addOLECheckBoxes()
Const srcName As String = "Sheet1"
Dim chk As OLEObject, rng As Range, cel As Range, i As Long
With ThisWorkbook.Worksheets(srcName)
Set rng = .Range("A1:A10")
i = 1
For Each cel In rng.Cells
Set chk = .OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=cel.Left, Top:=cel.Top, Width:=cel.Width, Height:=cel.Height)
With chk
'.Name = "Chk" & i
'.Placement = xlMoveAndSize
End With
i = i + 1
Next cel
End With
End Sub
I'm setting up a userform to find a company's name. Each company has 10 rows of data. I need the button to select the first row and then stop and only run the findnext if button is clicked again.
Currently my code finds the company's name correctly, but because of the loop it directly select the last row with the company's name. I need it to select the first time the name appears and then findnext only if I click on the button again
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long, c As String
Dim mycell As Range
lastrow = Sheets("Rent Roll").Range("A" & Rows.Count).End(xlUp).Row
c = TextBox1.Text
With Sheets("Rent Roll").Range("C5:C" & lastrow)
Set mycell = .Find(what:=c, LookIn:=xlValues)
If Not mycell Is Nothing Then
firstAddress = mycell.Address
Do
mycell.Select
Set mycell = .FindNext(mycell)
Loop While Not mycell Is Nothing And mycell.Address <> firstAddress
Else
MsgBox ("Not Found")
End If
End With
Exit Sub
End Sub
If I enter "Google", it should select the first row and then stop. Then if I click the button again, use findnext and select the next cell with "Google"
You should be able to to something like this:
Private Sub CommandButton1_Click()
Static lastCell As Range '<< static variables preserve values between calls
Static lastTerm As String
Dim ws As Worksheet, rngSrch As Range
Dim lastrow As Long, i As Long, c As String
Dim f As Range, afterCell As Range
Set ws = ThisWorkbook.Worksheets("Rent Roll")
Set rngSrch = ws.Range(ws.Range("C5"), ws.Cells(Rows.Count, "C").End(xlUp))
c = TextBox1.Text
'new search term?
If c <> lastTerm Then
Set lastCell = Nothing
lastTerm = c
End If
If Len(c) = 0 Then Exit Sub '<< nothing to search for
If lastCell Is Nothing Then
Set afterCell = Rng.Cells(Rng.Cells.Count)
Else
Set afterCell = lastCell
End If
Set f = rngSrch.Find(what:=c, after:=afterCell, LookIn:=xlValues)
If f Is Nothing Then
MsgBox ("'" & c & "' not found")
Else
If f.Row < lastCell.Row Then
MsgBox "Already at the last row" '<< do this, or just keep wrapping round?
Else
f.Select
Set lastCell = f
End If
End If
End Sub
I'm needing to find the first row numbers of cell in column C that contains "120" without duplicates (data I have has more than 10 of each number code, I only need the first one). So the code should pick up the first row number containing e.g. 120, 7120, 81200.
The code I've tried below have only managed to find the first row number with cell that contained 120. For reference, AGCL is a column letter derived from another find function and tbAC is a user input into a textbox.
Dim AGCN As Long
Dim AGCL As String
Dim AGNN As Long
Dim AGNL As String
Dim i As Long
Dim RowD As Long
Dim AAC As String
Dim rng As Range
Dim rownumber As Long
Dim AGC As Range
Dim AGN As Range
Dim firstaddress As Long
Dim nextaddress As Long
Set rng = Sheet1.Columns(AGCL & ":" & AGCL).Find(what:="*" & tbAC & "*",
LookIn:=xlValues, lookat:=xlPart)
rownumber = rng.Row
Debug.Print rownumber '9
With Sheet1.Range(AGCL & ":" & AGCL)
Set c = .Find("*" & tbAC & "*", LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Value
Debug.Print firstaddress
With Me.ListBox2
.ColumnCount = 3
.ColumnWidths = "50;150;70"
.AddItem
.List(i, 0) = Str(firstaddress)
i = o + 1
End With
Do
Set c = .FindNext(c)
If c Is Nothing Then
GoTo donefinding
ElseIf firstaddress <> c.Value Then
nextaddress = c.Value
Debug.Print nextaddress 'it doesn't print any value here
'With Me.ListBox2
' .ColumnCount = 3
' .ColumnWidths = "50;150;70"
' .AddItem
' .List(i, 0) = Str(nextaddress)
' Debug.Print nextaddress
' i = o + 1
'End With
End If
Loop While c.Address <> firstaddress
End If
donefinding: Exit Sub
End With
Any help would be greatly appreciated, thank you!
Here is the Range.FindNext Function you can use to retrieve all the cells having 120.
With Sheet1.Range(AGCL & ":" & AGCL)
Set c = .Find("*" & tbAC & "*", lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
If c is Nothing Then
GoTo DoneFinding
Elseif not firstaddress.value = c.value
''Whatever you want to do with the Second Found Value
debug.print c.value
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
Now to check that the value already found or not, you can play in the If Condition of this loop. So that you don't get the same values again.
UPDATED: Okay I updated one last time. As mentioned, I don't know what you want to do with the extra values... but this function will output them where ever...?
good luck.
Here's a custom function that matches what you're looking for, it will return the first time that 120 appears in a cell...
Here's one more that you could use if you truly wanted "contains" only a partial match.
Function SuperSearcherTHING(ivalue As Variant, theColumn As Range) As String
Dim rCell As Range
Const theSPACER As String = "|"
For Each rCell In Intersect(theColumn.EntireColumn, theColumn.Worksheet.UsedRange).Cells
If InStr(1, rCell.Value, ivalue, vbTextCompare) > 0 Then
SuperSearcherTHING = rCell.Value & theSPACER & SuperSearcherTHING
End If
Next rCell
SuperSearcherTHING = Left(SuperSearcherTHING, Len(SuperSearcherTHING) - Len(theSPACER))
End Function