My j is the problem. VB is asking me to declare it but thats not what i want. Im trying to add all if not already in a listbox from combo box. And at the end saying how many i have added.
'Delcare
Dim bolItemFound As Boolean
Dim intCounter As Integer
'Adding all items not already listed
For i = 0 To lstToPackItems.Items.Count - 1
For j() = 0 To cboStandardToPackItems.Items.Count - 1
If lstToPackItems.Items.Count < 0 Then
lstToPackItems.Items.Add(cboStandardToPackItems.Items)
End If
Exit Sub
If lstToPackItems.Items(i).ToString.ToUpper = cboStandardToPackItems.Items(j).ToString.ToUpper Then
bolItemFound = True
End If
Exit Sub
Next
If bolItemFound = False Then
'add item
intCounter += 1
lstToPackItems.Items.Add(cboStandardToPackItems.Items(j))
MsgBox("You have successfuly added " & intCounter & " item(s) to your list box!")
End If
Next
In this line:
For j() = 0 To cboStandardToPackItems.Items.Count - 1
you should not have parentheses after the j.
Related
Below code works great as expected the only downside is its slow because I am using this to search for all the instances of the substring and delete the Entire row if found in any cell of the whole workbook.
Aim is simple just delete the entirerow if the entered string is found in any cell string
Dim wo As Worksheet, ws As Worksheet
Dim I As Long, j As Long, m As Long
Dim toFind As String, testStr As String
Dim pos As Long
Dim lstRow As Long, cutRow As Long
Dim WS_Count As Integer
Dim Cell As Range
Option Compare Text
Option Explicit
Sub SearchDelete()
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
j = 0
If toFind = "" Then
MsgBox "Empty String Entered.Exiting Sub Now."
Exit Sub
Else
WS_Count = ActiveWorkbook.Worksheets.Count
'Begin the loop.
For I = 1 To WS_Count
Label1:
For Each Cell In Worksheets(I).UsedRange.Cells
If Trim(Cell.Text) <> "" Then
pos = 0
pos = InStr(1, Trim(Cell.Text), toFind, vbTextCompare)
If pos > 0 Then 'match Found'
cutRow = Cell.Row
Worksheets(I).Rows(cutRow).EntireRow.Delete
j = j + 1
GoTo Label1
Else: End If
Else: End If
Next Cell
Next I
End If
MsgBox "Total " & j & " Rows were deleted!"
End Sub
Individual operations are pretty much always slower than bulk operations and the Range.Delete method is no exception. Collecting the matching rows with a Union method and then performing the removal en masse will significantly speed up the operation.
Temporarily suspending certain application environment handlers will also help things along. You do not need Application.ScreenUpdating active while you are removing rows; only after you have completed the operation.
Option Explicit
Option Compare Text
Sub searchDelete()
Dim n As Long, w As Long
Dim toFind As String, addr As String
Dim fnd As Range, rng As Range
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
If Not CBool(Len(toFind)) Then
MsgBox "Empty String Entered.Exiting Sub Now."
GoTo bm_Safe_Exit
End If
'appTGGL bTGGL:=False 'uncomment this line when you have finsihed debugging
With ActiveWorkbook
For w = 1 To .Worksheets.Count
With .Worksheets(w)
Set fnd = .Cells.Find(what:=toFind, lookat:=xlPart, _
after:=.Cells.SpecialCells(xlCellTypeLastCell))
If Not fnd Is Nothing Then
Set rng = .Rows(fnd.Row)
n = n + 1
addr = fnd.Address
Do
If Intersect(fnd, rng) Is Nothing Then
n = n + 1
Set rng = Union(rng, .Rows(fnd.Row))
End If
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address
Debug.Print rng.Address(0, 0)
rng.Rows.EntireRow.Delete
End If
End With
Next w
End With
Debug.Print "Total " & n & " rows were deleted!"
bm_Safe_Exit:
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Debug.Print Timer
End Sub
The answer to your question: "How to speed up this code to find and delete rows if a substring is found" is - DON'T repeat the search from the top of the sheet after you found and removed the row!
So I have the script below in Execl VB that goes through the rows and deletes the ones that don't contain a certain keyword.
Sub Main()
RowsDeleted = 0
Keyword = "COLA"
For i = 2 to ActiveSheet.UsedRange.Rows.Count
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
i = i - 1
End If
Next i
MsgBox("Rows Deleted: " & RowsDeleted)
End Sub
The problem is that this script takes a very long time to execute (around 8 minutes for ~73000 entries). Why is that and how would I go about improving it?
no offense to other answer, but this will only help with troubleshooting.
what you need to do is remove the the line of code
Rows(i).Delete
inside the (potentially) long running For loop is what is causing the slow down.
you need to re-write it like this...
Sub Main()
RowsDeleted = 0
Keyword = "COLA"
Dim rng As Excel.Range
Dim arr() As Variant
Dim str As String
arr = ActiveSheet.UsedRange
Dim R As Long
For R = 1 To UBound(arr, 1) ' First array dimension is rows.
If InStr(arr(R, 1), Keyword) = 0 Then
If str <> "" Then
str = "," & str
End If
str = str & arr(R, 1).Address
End If
Next R
Set rng = ActiveSheet.Range(str)
RowsDeleted = rng.Rows.Count
rng.Delete
MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub
It takes ages may due to formulas in your cells that are going to be deleted.
What you should do is to turn off auto calculation and Clear the contents of that row before delete. Also you should start from bottom up!
Try this:
Sub Main()
Dim lMode As Long
' Store initial state of Calculation mode
lMode = Application.Calculation
' Change to Manual Calculation
Application.Calculation = xlCalculationManual
' Disable screen update
Application.ScreenUpdating = False
RowsDeleted = 0
Keyword = "COLA"
' Start from bottom up!
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).ClearContents
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
End If
Next i
' Restore screenupdate and calculation mode
Application.ScreenUpdating = True
Application.Calculation = lMode
MsgBox ("Rows Deleted: " & RowsDeleted)
End Sub
Here could be something to look at,
It filters Column A for cells <>"Cola" and clears them
It then sorts column A so the blank cells in column A are now at the bottom
It then deletes the blank rows.
Not knowing the setup of the OP's ws, there may have to be adjustments made.
On my sample sheet I use 81,000 rows, when I run the code it takes about 5 seconds.
Sub SomeDeleteCode()
Dim Rws As Long, Rng As Range, nwRw As Long
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = 0
Application.Calculation = xlCalculateManual
Columns("A:A").AutoFilter Field:=1, Criteria1:="<>*Cola*"
Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeVisible)
Rng.ClearContents
ActiveSheet.AutoFilterMode = 0
Columns(1).Sort Key1:=Range("A1"), Header:=xlYes
nwRw = Cells(Rows.Count, "A").End(xlUp).Row
Range(Range("B" & nwRw + 1), Range("B" & nwRw + 1).End(xlDown)).EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
End Sub
Amend your code to look like this:
Sub Main()
On Error Goto ErrHandler
Application.ScreenUpdating = False
RowsDeleted = 0
Keyword = "COLA"
For i = ActiveSheet.UsedRange.Rows.Count to 2
If InStr(Cells(i, 1).Value, Keyword) = 0 Then
Rows(i).Delete
RowsDeleted = RowsDeleted + 1
' i = i - 1 ' -- manually changing the loop counter is a bad idea
End If
Next i
MsgBox("Rows Deleted: " & RowsDeleted)
EndSub:
Application.ScreenUpdating = True
exit sub
ErrHandler:
' Error handling here
resume EndSub
End Sub
The error handler is required to ensure that the ScreenUpdating is restored, even in case of an error.
i have huge problem with my event procedure, it takes ages to run when i want to change more than few cells at once. How it works, well when user changes data in cell the Worksheet_Change adds comments, but first the Worksheet_SelectionChange updates informations for user (i have sumifs in different worksheet where it calculates ACT date for 12 months, and then it display via camer tool on active worksheet).
In know that problem is cuz of constant looping through events.... duno what to do ?!
Thx for help!
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
ActiveSheet.Unprotect Password:="xyz"
For Each cell In Target
If cell.Row > 21 And cell.Column > 9 Then
If cell.Comment Is Nothing Then
cell.AddComment Now & " - " & cell.Value & " - " & Application.UserName
Else
If Val(Len(cell.Comment.Text)) > 255 Then
cell.Comment.Delete
cell.AddComment
cell.Comment.Text _
Now & " - " & cell.Value & " - " & Application.UserName, 1 _
, False
Else
cell.Comment.Text _
vbNewLine & Now & " - " & cell.Value & " - " & Application.UserName, Len(cell.Comment.Text) + 1 _
, False
End If
End If
cell.Comment.Shape.TextFrame.AutoSize = True
End If
Next cell
ActiveSheet.Protect Password:="11opkLnm890", AllowFiltering:=True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RowNumber As Long, i As Long
Dim MaxRowNumber As Long
MaxRowNumber = Range("A9").Value
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
RowNumber = Target.Row
Set sh_AUXILIARY_PT = ThisWorkbook.Worksheets("AUXILIARY_PT")
If Target.Row > 21 And Target.Row < MaxRowNumber Then
sh_AUXILIARY_PT.Range("AA4").Value = Cells(RowNumber, 1).Value
sh_AUXILIARY_PT.Range("AB4").Value = Cells(RowNumber, 2).Value
sh_AUXILIARY_PT.Range("AC4").Value = Cells(RowNumber, 3).Value
sh_AUXILIARY_PT.Range("AD4").Value = Cells(RowNumber, 4).Value
For i = 14 To 25
sh_AUXILIARY_PT.Cells(8, i).Value = Cells(RowNumber, i - 4).Value
Next i
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
well, you may consider assigning your collection range to an Array and then loop through since Arrays are much faster.
Below I have some code that I have written. It is compeletely effective and gives no errors. However, it is very, very slow. The sub takes a given sheet with a table on it and checks for hidden rows. If all the rows are hidden, it deletes the sheet. If not, then it deletes all the hidden rows.
This is run in another sub, where all things like screenupdating and events are disabled.
I have researched common ways to speed up code (here: How to improve the speed of VBA macro code?, here: http://www.databison.com/how-to-speed-up-calculation-and-improve-performance-of-excel-and-vba/, and here: http://www.ozgrid.com/VBA/SpeedingUpVBACode.htm), but haven't been able to apply too many of them.
Please take a look and let me know what you think I could do to speed this up. If there are any other proper coding mistakes I have made, please let me know those as well.
Thanks!
Sub RhidRow(ByVal count4 As Double) 'count 4 is the total number of possible rows
Dim count6, count1, count9 As Double 'counters to be used
count6 = 2 'begin on row two
count1 = 0 'check for visible rows counter
With ActiveSheet
While count6 < count4
DoEvents
Application.StatusBar = "Checking row " & count6 & " of " & count4 & "."
If Range("A" & CStr(count6)).EntireRow.Hidden = False Then
count1 = count1 + 1 'if there was a visible row, then add one
End If
count6 = count6 + 1 'move to next row to check
Wend
Range("N7") = count6 'so I can hand check results
If count1 = 0 Then 'if there were no visible rows, then set Z1 to 1 and exit
Range("Z1").Value = 1 'to error check in another sub. if Z1=1, then delete
Exit Sub
End If
count6 = 2 'start on row 2
count9 = 1 'count 9
While count9 < count4 'while the row is less than the count of the total rows
DoEvents
Application.StatusBar = count6 & " or " & count9 & " of " & count4
If Range("A" & CStr(count6)).EntireRow.Hidden = True Then
Range("A" & CStr(count6)).EntireRow.Delete 'if row is hidden, delete
Else
count6 = count6 + 1 'if it is not hidden, move to the next row
End If
count9 = count9 + 1 'show what row it is on in the status bar
Wend
End With
End Sub
I have made the change suggested in the comments and gotten rid of ActiveSheet. The speed was unaffected.
Sub RhidRow(ByVal count4 As Double, shtO As Object) 'count 4 is the total number of possible rows
Dim count6, count1, count9 As Double 'counters to be used
count6 = 2 'begin on row two
count1 = 0 'check for visible rows counter
With shtO
While count6 < count4
DoEvents
Application.StatusBar = "Checking row " & count6 & " of " & count4 & "."
If Range("A" & CStr(count6)).EntireRow.Hidden = False Then
count1 = count1 + 1 'if there was a visible row, then add one
End If
count6 = count6 + 1 'move to next row to check
Wend
Range("N7") = count6 'so I can hand check results
If count1 = 0 Then 'if there were no visible rows, then set Z1 to 1 and exit the sub
Range("Z1").Value = 1 'this is used to error check in another sub. if Z1 is 1, then the sheet is deleted
Exit Sub
End If
count6 = 2 'start on row 2
count9 = 1 'count 9
While count9 < count4 'while the row is less than the count of the total rows
DoEvents
Application.StatusBar = "Deleting hidden rows. " & count6 & " or " & count9 & " of " & count4 & " done."
If Range("A" & CStr(count6)).EntireRow.Hidden = True Then
Range("A" & CStr(count6)).EntireRow.Delete 'if the row is hidden, delete it
Else
count6 = count6 + 1 'if it is not hidden, move to the next row
End If
count9 = count9 + 1 'show what row it is on in the status bar
Wend
End With
End Sub
Maybe something like this:
Sub RhidRow(ByVal count4 As Double) 'count 4 should be a Long, not Double
Dim count1 As Long 'counters to be used
Dim ws As Worksheet
Dim rngVis As Range
Dim rngDel As Range
Set ws = ActiveSheet
On Error Resume Next
Set rngVis = ws.Range("A2:A" & count4).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngVis Is Nothing Then
ws.Range("Z1").Value = 1
Else
For count1 = count4 To 2 Step -1
If ws.Rows(count1).Hidden = True Then
If rngDel Is Nothing Then
Set rngDel = ws.Rows(count1)
Else
Set rngDel = Union(rngDel, ws.Rows(count1))
End If
End If
Next count1
If Not rngDel Is Nothing Then
Application.DisplayAlerts = False
Intersect(rngDel, rngDel.ListObject.DataBodyRange).Delete 'if row is hidden, delete
Application.DisplayAlerts = True
End If
End If
End Sub
This might be a bit quicker:
Sub RowKleaner()
Dim rBig As Range, r As Range, rDelete As Range
ActiveSheet.UsedRange
Set rBig = Intersect(ActiveSheet.UsedRange, Range("A:A"))
Set rDelete = Nothing
For Each r In rBig
If r.EntireRow.Hidden = True Then
If rDelete Is Nothing Then
Set rDelete = r
Else
Set rDelete = Union(rDelete, r)
End If
End If
Next r
If Not rDelete Is Nothing Then
rDelete.EntireRow.Delete
End If
End Sub
the below will delete the sheet (or flag I left the logic for you to decide) if all rows are hidden, or will delete only the hidden rows if not:
Dim rngData As Range, rngVisible As Range, rngHidden As Range
Set rngData = Range("C8:H20")
Set rngVisible = rngData.SpecialCells(xlCellTypeVisible)
Set rngHidden = Range("A:A")
If (rngVisible Is Nothing) Then
' delete sheet or flag
Else
' invert hidden / visible
rngHidden.Rows.Hidden = False
rngVisible.Rows.Hidden = True
' delete hidden and show visible
rngData.SpecialCells(xlCellTypeVisible).Delete
rngVisible.Rows.Hidden = False
End If
This is my code that tries to set the text of a ComboBox when I click an item in a ListView.
Private Sub ListView1_Click()
If ListView1.ListItems.Count > 0 Then
Text1.Text = ListView1.ListItems(ListView1.SelectedItem.Index).Text
Text2.Text = ListView1.ListItems(ListView1.SelectedItem.Index).ListSubItems(1).Text
Sql = "SELECT A.AID,B.LOC_NAME,C.SNAME FROM ASSET A,LOCATION B,SUPPLIER C WHERE "
Sql = Sql + "A.LOC_ID=B.LOC_ID AND A.SUP_ID=C.SUP_ID AND AID=" & Text1.Text
RS.Open Sql, CON, 1, 2
COM1
Combo1.Text = RS!LOC_NAME //combo with style - 2
COM5
Combo5.Text = RS!SNAME //combo with style - 2
End If
End Sub
Private Sub COM5()
If Combo5.ListIndex = -1 Then
For I = 0 To Combo5.ListCount - 1
Combo5.ListIndex = I
Next
End If
End Sub
Private Sub COM1()
If Combo1.ListIndex = -1 Then
For I = 0 To Combo1.ListCount - 1
Combo1.ListIndex = I
Next
End If
End Sub
However, when I click on the ListView1, I get this error:
'text' property is read only
Can anyone explain why?
For a combobox with the dropdown list style you can only select an item with .text if that item already exists, so combo1.text = "xxx" errors if "xxx" is not present in the list.
To select or add based on existence you can;
Private Sub SelectOrAddToCombo(combo As ComboBox, value As String)
Dim i As Long
With combo
For i = 0 To combo.ListCount - 1
If StrComp(.List(i), value, vbTextCompare) = 0 Then
combo.ListIndex = i
Exit Sub
End If
Next
.AddItem value
.ListIndex = .NewIndex
End With
End Sub
...
SelectOrAddToCombo Combo1, RS!LOC_NAME
SelectOrAddToCombo Combo5, RS!SNAME
It's not clear what the point of your COM5()/COM1() routines are.
For the listview, rather than click look at the
ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
event which passes you the clicked item negating the need for ListView1.SelectedItem (which can cause errors if its Nothing).
yes, you must populate the combobox with the array(using additem value) before set the .text propierty, if the text that you want to set on the combobox does not exits in the array you get this error