I have a table with two data columns. I need to find the line where both of them are a hit. So far this is what my code looks like:
Dim ws As Worksheet
Set ws = Worksheets(1)
Set rgfound = ws.Range("A:A").Find(MyInputOne.value), LookAt:=xlWhole)
If rgfound Is Nothing Then
MsgBox "No results"
Exit Sub
Else
If rgfound.Offset(0, 3).Value <> MyInputTwo.Value Then
Do
Set rgfound = ws.Range("A:A").FindNext(rgfound)
Loop Until rgfound.Offset(0, 3).Value = MyInputTwo.Value
End If
End If
rgfound.Offset(0, 5).Value = "Found!"
This enters an infinite loop and crashes, and I have to force quit excel after running it.
Any advice will be appreciated.
I wouldn't use loops for this kind of thing.
The built in AutoFilter is super quick if you know how to manipulate it in VBA and it will avoid any need for loops/ problems with infinite loops
Here's the code:
Option Explicit
Sub FindBoth()
Dim sht As Worksheet
Dim data As Range, result As Range
Set sht = ThisWorkbook.Worksheets("Sheet1")
Set data = sht.Range("A1:D101")
sht.AutoFilterMode = False 'clear existing filter
With data
.AutoFilter field:=1, Criteria1:=8
.AutoFilter field:=4, Criteria1:="A"
Set result = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Rows(1)
If Not Intersect(result, data) Is Nothing Then
result.Offset(0, 5).Resize(1, 1).Value = "Found!"
End If
End With
sht.AutoFilterMode = False
End Sub
My data looked like this:
Most probably it loops to infinity, because the code never satisfies this condition:
Loop Until rgfound.Offset(0, 3).Value = MyInputTwo.Value
To see what is happening write:
Debug.Print rgfound.Offset(0, 3).Value
Debug.Print MyInputTwo.Value
before the condition above. Another option to check what is happening is to introduce some counter, which would force the code to stop after the 2000. iteration. Like this:
Public Sub TestMe()
Dim cnt As Long
Do
cnt = cnt + 1
Debug.Assert cnt < 2000
Debug.Print cnt
Loop Until False
End Sub
Once it stops because of the fail of the Debug.Assert condition, you would be able to debug manually and to get what is happening.
Definitely the most simplistic answer here, but if you know your parameters and it should never 'Loop' over a certain amount of times, you can try putting a FOR I / NEXT I statement.
Just another idea to throw out there.
Related
Essentially, when running the below code within one workbook (1 sheet) it completes within an instant. But when using it in my main workbook (couple of sheets, barely any data) it takes a while to complete. How can I optimize the below code?
Sub DeleteBlankRows()
On Error Resume Next
Sheets("Sheet4").Activate
Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Try avoiding the use of an entire column, as well as .Activate:
Sub DeleteBlankRows()
' On Error Resume Next
Dim lastRow As Long
With Sheets("Sheet4")
lastRow = .Cells(Rows.Count, 4).End(xlUp).row
.Range(.Cells(1, 4), .Cells(lastRow, 4)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub
Edit: Commented out the On Error Resume Next
you could try too to stop the automatic calculation and screen update and at the end reenable all.
try this and test too with the other codes
Sub DeleteBlankRows()
Application.ScreenUpdating = False
Application.Calculation = xlManual
On Error Resume Next
Sheets("Sheet4").Activate
Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = true
Application.Calculation = xlAutomatic
End Sub
Good Luck
lastRow = .Cells(Rows.Count, 4).End(xlUp).row
I never use this method for figuring out last row. It takes too long... Basically processing every cell starting from the bottom of the worksheet. Instead, I count the number of cells with values. I use that number to run a for loop which tests to see if there is a value in a given cell and counts until all cells with values are accounted for. Code wise, its more complicated... but in my experience executes more quickly.
kount = Application.WorksheetFunction.CountA(krng) 'Count how many used cells there are
kRow = 1
j = 1
Do Until j = kount + 1 'Do until all used cells are acounted for
If Cells(kRow, l).Value = vbNullString Then 'If current cell is empty skip it
Else
j = j + 1 'If the current cell has a value count up
End If
kRow = kRow + 1 'but go on to the next row either way
Loop
Where kRow is the last row with a value
I wrote a small VBA macro to compare two worksheets and put unique values onto a new 3rd worksheet.
The code works, but every time I use if excel goes "not responding" and after 30-45sec comes back and everything worked as it should.
Can I make this faster and get rid of the "not responding" issue? is it just my computer not being fast enough?
I start with about 2500-2700 rows in each sheet I'm comparing.
Sub FilterNew()
Dim LastRow, x As Long
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Sheets(1).Select
LastRow = Range("B1").End(xlDown).Row
Application.ScreenUpdating = False
For Each Cell In Range("B2:B" & LastRow)
x = 2 'This is for looking through rows of sheet2
Dim unique As Boolean: unique = True
Do
If Cell.Value = Sheets(2).Cells(x, "B").Value Then 'Test if cell matches any cell on Sheet2
unique = False 'If the cells match, then its not unique
Exit Do 'And no need to continue testing
End If
x = x + 1
Loop Until IsEmpty(Sheets(2).Cells(x, "B"))
If unique = True Then
Cell.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
End Sub
This belongs in Code Review, but here is a link
http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html
With your code your main issues are:
Selecting/Activating Sheets
Copy & pasting.
Fix those things and youll be set straight my friend :)
instead of a do...loop to find out duplicate, I would use range.find method:
set r = SHeets(2).range("b:b").find cell.value
if r is nothing then unique = true else unique = false
(quickly written and untested)
What about this (it's should help):
Sub FilterNew()
Dim Cel, Rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Set Rng = Sheet(1).Range("B2:B" & Sheet(1).Range("B1").End(xlDown).Row)
For Each Cel In Rng
If Cel.Value <> Sheet(2).Cells(Cel.Row, 2).Value Then Cel.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) ' The only issue I have with this is that this doesn't actually tell you if the value is unique, it just tells you ins not on the same rows of the first and second sheet - Is this alright with you?
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I've set up some VBA code in Excel that asks the user to select a second worksheet, then searches it for a value (a shared key linking the two sets of data, found 6 columns after Rng, where I want to add the retrieved value) in the second table and adds a value from that row to a column in the original table. The part of the program that I would like to adjust is the loop below.
It works fine if when I leave in the line to activate the CurFile workbook. But it means my screen is flashing a lot back and forth between the two workbooks. And once I start getting into hundreds or thousands of lines of data it will be ridiculously slow.
When I comment out that line, the value for FindCID doesn't change and it seems to just keep on refilling the same line, even though the value for r is updating. If after a few loops I add the activate line back in, it resumes properly filling in the results several lines down.
How can I streamline this? I originally was using ThisWorkbook references but even with explicitly defining CurFile (CurFile = ActiveWorkbook.Name) earlier it doesn't seem to go back to that workbook to look up the next value to search for, unless I reactivate the sheet.
Do While r <= maxRows
With Workbooks(CurFile).Worksheets("Sheet1")
Set Rng = .Range(Cells(r, c), Cells(r, c))
End With
FindCID = Rng.Offset(0, 6).Value
If Trim(FindCID) <> "" Then
With Workbooks(FN) ' found earlier by a function
.Activate
End With
With Sheets("Sheet1").Range("D:D")
Set FoundCell = .Find(What:=FindCID)
If Not FoundCell Is Nothing Then
PathLen = FoundCell.Offset(0, 2).Value
Workbooks(CurFile).Sheets("Sheet1").Activate 'If I comment out this line it doesn't work
Rng.Value = PathLen
MsgBox "CID found in " & FoundCell.Address & " Its value is " & PathLen
Else
MsgBox "Nothing found"
End If
End With
End If
On Error Resume Next
r = r + 1
Loop
Actually when working with objects, in most of the cases, there is no need to activate the workbooks\worksheets.
This is your code with some modifications in this regard:
Application.ScreenUpdating = False '(as suggested by CBRF23)
'......
'begining of your code
'......
Do While r <= maxRows
With Workbooks(CurFile).Worksheets("Sheet1")
Set Rng = .Cells(r, c) '(1)
End With
FindCID = Rng.Offset(0, 6).Value2
If Trim(FindCID) <> "" Then
Set FoundCell = Workbooks(FN).Sheets("Sheet1").Range("D:D").Find(What:=FindCID)
If Not FoundCell Is Nothing Then Rng.Value = FoundCell.Offset(0, 2).Value2
End If
r = r + 1
Loop
'......
'rest of your code
'......
Application.ScreenUpdating = True
(1) Notice that way the Range is defined as it’s made of only once Cell; but if the range has more than one Cell i.e. from Cell(r,c) to Cell(r,c+5) then you need to use the form:
Set Rng = Range(.Cells(r, c), .Cells(r, c+5))
There is no need to add a period . before Range as the range is defined by the Cells within the Range command. By using the period . before the Cell command they are referred as part of the
With Workbooks(CurFile).Worksheets("Sheet1")
However if the Range is defined as A1:F1 then the period . has to be added before the Range as in:
Set Rng = .Range(“A1:F1”)
I removed the MsgBox commands as I believe they were just for testing purposes. Not really showing these messages for hundreds or thousands lines of data. Isn’t it?
I have recorded and polished the following macro which should create an extra sheet with hypertext links pointing on a starting cell of each table within the original sheet called "All_tables". In this sheet, every single table is separated by a hash symbol (#). See a screenshot:
Sub Create_list_of_tables()
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "list of tables"
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"All_Tables!A22", TextToDisplay:="some variable pointing at the table name"
Range("A2").Select
End Sub
Now I would like to put it into a loop which would repeat itself ten (or more) times. I tried to use the hash symbol as a reference point for a program to find out at which cell he should point the hyperlink. Here is the result:
Sub Create_list_of_tables()
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "list of tables"
Const cStrDivider As String = "#"
Dim rMyCell As Range
Dim table_number As Long
table_number = 0
Do Until table_number = 10
Set rMyCell = Range("cStrDivider").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"All_Tables!&rMyCell", TextToDisplay:="some variable pointing at the table name"
ActiveCell.Offset(1, 0).Select
table_number = table_number + 1
Loop
End Sub
And it doesn't work. I am totally new to macro and VB programming so I'd be really happy if you could at least show me the direction. Is my approach is completely wrong?
Thank you so much
I'm not sure exactly where you want your hyperlink pointing but this should get you a good start. Things to look out for:
Don't use Select or Selection statements. They are slow and can produce undesirable effects. Instead use very explicit statements that do not depend on cursor position but rater the absolutle position of where you know things are.
Use the Find and FindNext method of a range object to locate strings. When FindNext can't find anything more it returns nothing. Good to check for instead of doing your table_number loop.
updated
Sub Create_list_of_tables()
Const cStrDivider As String = "#"
Dim sht As Worksheet, rMyCell As Range, rSearchRange As Range
Dim testSht As Worksheet, firstMyCell As Range
Set sht = ActiveSheet
On Error Resume Next
Set testSht = ActiveWorkbook.Sheets("All_Tables")
If Err.Number <> 9 Then
Application.DisplayAlerts = False
testSht.Delete
Application.DisplayAlerts = True 'important to set back to true!
End If
On Error GoTo 0
ActiveWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
ActiveWorkbook.Sheets(Sheets.Count).Name = "All_Tables"
Set rSearchRange = sht.Range("A:A")
'do initial "Find"
Set rMyCell = rSearchRange.Find(cStrDivider)
Set firstMyCell = rMyCell
Do
sht.Hyperlinks.Add Anchor:=rMyCell.Offset(0, 1), Address:="All_Tables!" & rMyCell.Address, _
TextToDisplay:="Link"
'get the next "MyCell" to use from the master range to search
Set rMyCell = rSearchRange.FindNext(rMyCell)
'increment your table counter (if you want to do this you can still
table_number = table_number + 1
Debug.Print firstMyCell.Address
Debug.Print rMyCell.Address
Loop While firstMyCell.Address <> rMyCell.Address
End Sub
See how that works an move on from there.
I wrote this script to delete rows which contain a value in column C that is different than "201103". When I use this to bold it, it works, but when I use it with .Delete it behaves strange and does not work properly.
I was trying to get selected rows and than use UNION to merge it and use .SELECT (multiple) so I could delete it manually but not sure how to make it.
Sub test()
Dim Cell As Range
For Each Cell In Range("C2:C2308").Cells
If (Cell.Value <> "201103" And Cell.Value <> "") Then
Cell.EntireRow.Font.Bold = True
'Cell.EntireRow.Delete
End If
Next Cell
End Sub
Does anyone know how to fix it so it works fine?
Try this:
Sub test()
'
With ActiveSheet
.AutoFilterMode = False
With Range("C2", Range("C" & Rows.Count).End(xlUp))
.AutoFilter 1, "<>201103"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End Sub