I have a2 richtext box first one called a1 second one b2 . Both of them have texts
What im trying to do is : delete any line that a2 has from b2
So if a2 contain lines
First line = 1256
Second one = 5678
....etc
I want to remove any line in b2 that contain this lines in a2 1256 and 5678 ..etc
I tried to use filter but that took long time because there are alot of lines and didnt work
I tried to solve your problem so i reached to this(it's not completely what you want but it may help you) :
Public Class Form1
Dim CheckChar, CheckedChar As String
Dim CheckedNum As Integer = 1
Private Sub CheckBUT_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles CheckBUT.Click
If Not a1.Text = "" Then
If a1.Text.Length > 2 Then
ReRead: If CheckedNum = 1 Then
CheckChar = a1.Text.Remove(1)
Else
CheckChar = a1.Text.Substring(CheckedNum - 1)
If Not CheckedNum = a1.Text.Length Then
CheckChar = CheckChar.Remove(1)
End If
End If
If CheckChar.Contains("" & vbLf & "") Then
CheckedChar = a1.Text.Remove(CheckedNum - 1)
CheckChar = b2.Find(CheckedChar)
If Not CheckChar = -1 Then
b2.Text = b2.Text.Replace(CheckedChar & ("" & vbLf & ""), "")
End If
Else
a1.Text.Substring(CheckedNum - 1)
End If
If CheckedNum = a1.Text.Length Then
CheckedNum = 1
Else
CheckedNum = CheckedNum + 1
GoTo ReRead
End If
End If
End If
End Sub
End Class
I Hope The Code was Useful to You
Related
I have tried to change the code but it didnt works.
Here is my code:
Private Sub CTcash_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
bill = Val(CTcash.Text - CLtotaloutput.Caption)
If Val(bill) > 0 Then
Change.CLchange.Caption = Val(bill)
Change.CLchange.Caption = Format(bill, "Rp\. ###,###,###.-")
Change.Show
End If
If Val(bill) < 0 Then
MsgBox "Not Enough Money", vbOKOnly, "Invalid"
End If
End If
End Sub
The highlighted code
bill = Val(CTcash.Text - CLtotaloutput.Caption)
Both CTcash.Text and CLTotaloutput.Caption are text strings so you can't subtract them directly. Try:
bill = Val(CTcash.text) - Val(CLtotaloutput.Caption)
You really should ensure that both strings are numerical first though!
#John Eason is correct. You also do not have to use Val on bill since it is already an integer. And you are not doing anything if bill is 0 but this could be fine based on your requirements.
Private Sub CTcash_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
bill = Val(CTcash.Text) - Val(CLtotaloutput.Caption)
If bill > 0 Then ' Note that when bill is 0 nothing happens but that might be fine
'Change.CLchange.Caption = bill 'Not sure why this is needed but it may be
Change.CLchange.Caption = Format(bill, "Rp\. ###,###,###.-")
Change.Show
End If
If bill < 0 Then
MsgBox "Not Enough Money", vbOKOnly, "Invalid"
End If
End If
End Sub
I think a better approach would be to use a Select Case statement.
Private Sub CTcash_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
bill = Val(CTcash.Text) - Val(CLtotaloutput.Caption)
Select Case True
Case bill > 0
Change.CLchange.Caption = Format(bill, "Rp\. ###,###,###.-")
Change.Show
Case bill < 0
MsgBox "Not Enough Money", vbOKOnly, "Invalid"
Case Else
' Do nothing - this documents that this is done on purpose
End Select
End If
End Sub
You can use IsNumeric function to check if the inputs are numeric and parse accordingly. Use the Right function to remove any non-numbers from the left side. For example, Right("$123", Len("$123") - 1) will remove the leading $.
To strip all non-numerical values from a string:
Dim ResultString As String
myString = "aaa34BB12,000xcv9.9zz"
Dim i As Integer
For i = 1 To Len(myString)
myChar = Mid(myString, i, 1)
If IsNumeric(myChar) = True Then
ResultString = ResultString + myChar
End If
Next
MsgBox ResultString
Note that this may cause an issue with decimal amounts since 1.23 will before 123. Not something you want. Try using the CCur function. I have never used it myself but it might be exactly what you want.
Source: https://www.vbforums.com/showthread.php?437526-RESOLVED-Removing-non-numeric-chars-from-a-string&p=2686411&viewfull=1#post2686411
At first I miss the const, i put it in the other sub:
Private Sub CTcash_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
bill = Val(CTcash.Text) - totalsum
Select Case True
Case bill > 0
Change.CLchange.Caption = Format(bill, "Rp\. ###,###,###.-")
Change.Show
Case bill < 0
MsgBox "Not Enough Money", vbOKOnly, "Invalid"
Case Else
End Select
End If
End Sub
Private Sub CTbarcode_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case Is = vbKeyF6
totaldiscount = 200
totalsum = Val(CLsuboutput.Caption) - totaldiscount
CLtotaloutput.Caption = Format(totalsum, "Rp\. ###,###,###. ,-")
CLdiscoutput.Caption = Format(totaldiscount, "Rp\. ###,###,###. ,-")
CTcash.Enabled = True
CTcash.SetFocus
End Select
End Sub
Here is it after i edit it:
Private Sub CTcash_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
totaldiscount = 200
totalsum = Val(CLsuboutput.Caption) - totaldiscount
bill = Val(CTcash.Text) - totalsum
Select Case True
Case bill > 0
Change.CLchange.Caption = Format(bill, "Rp\. ###,###,###.-")
Change.Show
Case bill < 0
MsgBox "Not Enough Money", vbOKOnly, "Invalid"
Case Else
End Select
End If
End Sub
I would appreciate if anybody can help me with this issue I am having. Basically, the VBA is a search function that enables the user to search part of or the entire name of the job, from a job database.
However, it results in "Runtime error 7: Out of Memory." This happens only on my Macbook, and does not happen on a Windows computer. Upon clicking "debug", it brought me to this line of code:
`If scd.Cells(i, j) Like "*" & Search & "*" Then
please help! Thank you!
The rest of the code is below:
Option Compare Text
Sub SearchClientRecord()
Dim Search As String
Dim Finalrow As Integer
Dim SearchFinalRow As Integer
Dim i As Integer
Dim scs As Worksheet
Dim scd As Worksheet
Set scs = Sheets("Client Search")
Set scd = Sheets("Client Database")
scs.Range("C19:S1018").ClearContents
Search = scs.Range("C12")
Finalrow = scd.Range("D100000").End(xlUp).Row
SearchFinalRow = scs.Range("D100000").End(xlUp).Row
For j = 3 To 19
For i = 19 To Finalrow
If scd.Cells(i, j) Like "*" & Search & "*" Then
scd.Range(scd.Cells(i, 3), scd.Cells(i, 19)).Copy
scs.Range("C100000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
Next j
scs.Range("C19:S1018").Select
scs.Range("$C$18:$S$1009").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6 _
, 7), Header:=xlYes
Call Border
Columns("C:S").HorizontalAlignment = xlCenter
End Sub
I created an alternate function called "aLike" below.
In your code you would use it by saying: If aLike("*" & Search & "*",scd.Cells(i, j)) Then
I can't guarantee it works exactly the same way, but I would be interested to see if the Mac can process this function better than "like".
Function aLike(asterixString As Variant, matchString As Variant, Optional MatchCaseBoolean As Boolean) As Boolean
Dim aStr As Variant, mStr As Variant, aStrList As New Collection
Dim i As Long, aPart As Variant, mPart As Variant, TempInt As Long, aStart As Boolean, aEnd As Boolean
aStr = asterixString: mStr = matchString
If Not MatchCaseBoolean Then aStr = StrConv(aStr, vbLowerCase): mStr = StrConv(mStr, vbLowerCase)
' Get rid of excess asterix's
While InStr(aStr, "**") > 0
aStr = Replace(aStr, "**", "*")
Wend
' Deal with trivial case
If aStr = mStr Then aLike = True: GoTo EndFunction
If aStr = "*" Then aLike = True: GoTo EndFunction
If Len(aStr) = 0 Then aLike = False: GoTo EndFunction
' Convert to list
aStart = Left(aStr, 1) = "*": If aStart Then aStr = Right(aStr, Len(aStr) - 1)
aEnd = Right(aStr, 1) = "*": If aEnd Then aStr = Left(aStr, Len(aStr) - 1)
aLike_Parts aStr, aStrList
' Check beginning
If Not aStart Then
aPart = aStrList.Item(1)
If Not (aPart = Left(mStr, Len(aPart))) Then aLike = False: GoTo EndFunction
End If
' Check end
If Not aEnd Then
aPart = aStrList.Item(aStrList.Count)
If Not (aPart = Right(mStr, Len(aPart))) Then aLike = False: GoTo EndFunction
End If
' Check parts
mPart = mStr
For i = 1 To aStrList.Count
aPart = aStrList.Item(i): TempInt = InStr(mPart, aPart)
If TempInt = 0 Then aLike = False: GoTo EndFunction
mPart = Right(mPart, Len(mPart) - TempInt - Len(aPart) + 1)
If Len(mPart) = 0 And i < aStrList.Count Then aLike = False: GoTo EndFunction
Next i
aLike = True
EndFunction:
Set aStrList = Nothing
End Function
Function aLike_Parts(Str As Variant, StrList As Collection) As Variant
Dim Char As String, wPart As String
For i = 1 To Len(Str)
Char = Mid(Str, i, 1)
If Char = "*" Then
StrList.Add wPart: wPart = ""
Else
wPart = wPart & Char
End If
Next i
If Len(wPart) > 0 Then StrList.Add wPart
End Function
Good Luck!
#Alex P , now .find is NOT more efficient, for example :
Option Explicit
Option Compare Text
Sub SearchClientRecord()
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim Search As String
Dim Finalrow As Long
Dim SearchFinalRow As Long
Dim i&, j&
Dim scs As Worksheet
Dim scd As Worksheet
Dim DATA() As Variant
Dim Range_to_Copy As Range
Set scs = Sheets("Client Search")
Set scd = Sheets("Client Database")
With scd
Finalrow = .Range("D100000").End(xlUp).Row
DATA = .Range(.Cells(19, 3), .Cells(Finalrow, 19)).Value2
End With
With scs
.Range("C19:S1018").ClearContents
Search = .Range("C12").Value
SearchFinalRow = .Range("D100000").End(xlUp).Row
End With
With scd
For j = 3 To 19
For i = 19 To Finalrow
If InStr(DATA(i, j), Search) > 0 Then
'If scd.Cells(i, j) Like "*" & Search & "*" Then
If Not Range_to_Copy Is Nothing Then
Set Range_to_Copy = Union(Range_to_Copy, .Range(.Cells(i, 3), .Cells(i, 19)))
'scd.Range(scd.Cells(i, 3), scd.Cells(i, 19)).Copy
'scs.Range("C100000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
Else
Set Range_to_Copy = .Range(.Cells(i, 3), .Cells(i, 19))
End If
End If
Next i
Next j
End With 'scd
Erase DATA
With scs
Range_to_Copy.Copy _
Destination:=.Range("C100000").End(xlUp).Offset(1, 0) '.PasteSpecial xlPasteFormulasAndNumberFormats
.Range("C19:S1018").Select 'this line might be superflous
.Range("$C$18:$S$1009").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
End With
Call Border
Columns("C:S").HorizontalAlignment = xlCenter 'on wich worksheet ??
Set Range_to_Copy = Nothing
Set scs = Nothing
Set scd = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
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.
Inserted my progress bar and it didn't work as expected. When i logged in, it works, but it doesn't automatically loads the second form.
Here is my code for progress/timer
Private Sub Timer1_Timer()
If ProgressBar1.Value = 100 Then
ProgressBar1.Value = 0
Else
ProgressBar1.Value = Val(ProgressBar1.Value) + Val(20)
End If
Label3.Caption = ProgressBar1.Value
Label , to detect 100, variable prg to hold
Private Sub Label3_Change()
If (Label3.Caption = 100) Then
prg = 1
Timer1.Interval = 0
End If
End Sub
log in button
Private Sub cmdSign_Click()
currentTime = TimeValue(Now)
strCurrdate = Format(Date, "mmm d, YYYY")
rx.Open "Select * from login where username ='" & Text1 & "' and password='" & Text2 & "'", db, 3, 3
If (counter = 3) And (rx.EOF = True) Then
MsgBox "You guessed too many times! Intruder alert!"
End
Else
If rx.EOF = True Then
MsgBox "Invalid Username or Password"
counter = counter + 1
Text1 = ""
Text2 = ""
Else
user1 = Text1.Text
logTime = currentTime
rxd.Open "Select * from logHistory", db, 3, 3
With rxd
.AddNew
.Fields("username") = user1
.Fields("TimeDate") = strCurrdate
.Fields("TimeIn") = logTime
.Update
End With
Set rxd = Nothing
'problem might be here
ProgressBar1.Visible = True
Timer1.Interval = 100
Label3.Visible = True
Timer1.Enabled = True
If prg = 1 Then
MsgBox "Welcome " + Text1 + " to SPARTAN!"
mainmenu.Show
End If
End If
End If
Set rx = Nothing
End Sub
Any help on this?
Once the timer is started it runs asynchronously to the rest of your code. The way you have coded your login button you are expecting the timer to move the progressbar from 0 to 100, set your (I assume) module scoped variable prg to 1 and then continue. In reality your code enables the timer and moves on. When it reaches the If prg = 1 Then statement prg is still whatever it has been initialized at. One way to fix it is to check the prg variable in your timer event.
Private Sub Timer1_Timer()
If ProgressBar1.Value = 100 Then
Timer1.Enabled = False ' don't fire the timer event again
ProgressBar1.Value = 0
MsgBox "Welcome " & Text1 & " to SPARTAN!"
mainmenu.Show
Else
ProgressBar1.Value = Val(ProgressBar1.Value) + Val(20)
End If
Label3.Caption = ProgressBar1.Value
End Sub
I also changed your string concatenation + to &. The plus symbol "+" works, but is only included in VB versions after 3 for backward compatibility and it is considered bad form to use it for other than arithmetic. In VB version 4 and greater the ampersand "&" should be used for concatenation. MSDN reference here