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
Related
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.
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 need to build a linked search function in VBA that also auto-updates after you enter data into the given search fields. I have been able to do this successfully with the following sections of code:
Autofilter search - in a standard module
Code:
Sub FilterTo1Criteria()
With Sheet3
If Range("A3") <> vbNullString Then
.AutoFilterMode = False
.Range("A6:J1015").AutoFilter
.Range("A6:J1015").AutoFilter Field:=1, Criteria1:=Range("A3")
Else
Selection.AutoFilter
End If
End With
End Sub
Sheet change/auto-update - This is in a worksheet module
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$3" Then
Application.EnableEvents = False
FilterTo1Criteria
Application.EnableEvents = True
End If
End Sub
However, within the sheet change page, I need cells A3:J3 to be the criteria, but I also need the auto search function to work if only A3 and D3 are filled in, or if just A3 is filled in (D3 is blank), or if just D3 is filled in (A3 is blank), but I'm having issues trying to compound the code to get this effect. How much more complicated will I have to make it? Are there some examples that someone is aware of that I can look at to glean some information from? It's hard to find any...
A slicer with a pivot table is a potential way to go, but I think some people downstream are using Excel 2003 and I don't think the slicer works back that far.
Thanks in advance!
For the function to work if either A3 or D3 are not empty, then you can concatenate the two cells and compare that to vbNullString.
For the multiple filters, you can use a loop to set them all.
eg:
Sub FilterTo1Criteria()
Dim i As Long
With Sheet3
If Range("A3") & Range("D3") <> vbNullString Then
.AutoFilterMode = False
.Range("A6:J1015").AutoFilter
For i = 1 To 10
.Range("A6:J1015").AutoFilter Field:=i, Criteria1:=Cells(3, i)
Next i
Else
Selection.AutoFilter
End If
End With
End Sub
Edit:
It looks like you wanted to set the filters as the criteria cells were filled, rather than all at once. Try this instead:
Sub FilterTo1Criteria()
Dim i As Long
With Sheet3
.AutoFilterMode = False
.Range("A6:J1015").AutoFilter
For i = 1 To 10
If .Cells(3, i) <> vbNullString Then
.Range("A6:J1015").AutoFilter Field:=i, Criteria1:=.Cells(3, i)
End If
Next i
End With
End Sub
and for the new worksheet change sub:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$A$3:$J$3")) Is Nothing Then
Application.EnableEvents = False
FilterTo1Criteria
Application.EnableEvents = True
End If
End Sub
This will add or remove filters as you add or remove criteria (row 3).
I have a formula that shows which rows in a specific column meet a set of criteria. When the formula is executed and applied to all rows, I run a loop to check which rows returned a value as a text, and then copy-pastes this cells to another worksheet:
Sub loop1()
Dim r As Range, c As Range
With Worksheets("Sheet1")
Set r = Range(.Range("AF2"), .Range("AF2").End(xlDown))
For Each c In r
If WorksheetFunction.IsText(c) Then
Range(.Cells(c.Row, "AF"), .Cells(c.Row, "AF")).Copy
Else
GoTo nextc
End If
With Worksheets("Sheet2")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
nextc:
Next c
End With
Application.CutCopyMode = False
End Sub
What I want to do now is to run the formula for 631 different names, copy-paste every name as a headline and then run loop1. I cant figure out though how to make the for loop work inside the formula.
Sub loop2()
Dim i As Integer
For i = 2 To 632
Sheets("Sheet1").Select
Range("AC2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]=""district1"",(IF(RC[2]=R2C33 ,(IF(RC[-18]>=1,0,(IF(RC[-16]>=1,0,IF(RC[-14]>=1,0,IF(RC[-12]>=1,0,IF(RC[-10]>=1,1,IF(RC[-8]>=1,1,IF(RC[-6]>=1,1,0))))))))),0)),0)"
Range("AC2").Select
Selection.AutoFill Destination:=Range("AC2:AC20753")
Range("AC2:AC20753").Select
Range("AG2").Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Sheets("Sheet1").Select
Application.Run "'Customers.xlsb'!loop1"
Next i
End Sub
The cells that need to be changed for every loop are, R2C33 to something like RiC33 (which doesn't work) and the "headline" Range("AG2").Select to something like Range("AGi").Select.
Anyone who could help?
The following code will do the trick:
Sub loop2()
Dim i As Integer
For i = 2 To 632
Sheets("Sheet1").Range("AC2:AC20753").FormulaR1C1 = _
"=IF(RC[-3]=""district1"",(IF(RC[2]=R" & i & "C33 ,(IF(RC[-18]>=1,0,(IF(RC[-16]>=1,0,IF(RC[-14]>=1,0,IF(RC[-12]>=1,0,IF(RC[-10]>=1,1,IF(RC[-8]>=1,1,IF(RC[-6]>=1,1,0))))))))),0)),0)"
Sheets("Sheet1").Range("AG" & i).Copy Destination:=Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Range("A1").Font.Bold = True
Application.Run "'Customers.xlsb'!loop1"
Next i
End Sub
In order to let i be used within your String formula you have to stop the String " use & i & and continue the String ".
I have also changed your code to prevent the use of .Select, which is a no no in VBA.
This way it fills in your Formula copy's and changes the Font without selecting anything or changing sheets.
As Jeep noted you do however need to change Sheets(""Sheet2").Range("A1") as I don't know which cell you want to paste into.
Your first sub procedure might be better like this.
Sub loop1()
Dim r As Range, c As Range
With Worksheets("Sheet1")
Set r = Range(.Range("AF2"), .Range("AF2").End(xlDown))
For Each c In r
If WorksheetFunction.IsText(c) Then
Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = _
.Cells(c.Row, "AF").Value2
End If
Next c
End With
End Sub
Direct value transfer is preferred over a Copy, Paste Special, Values.
In the second sub procedure, you don't have to do anything but remove the 2 from R2C33; e.g. RC33. In xlR1C1 formula construction a lone R simply means the row that the formula is on and you are starting at row 2. You can also put all of the formulas in at once. Once they are in you can looop through the G2:G632 cells.
Sub loop2()
Dim i As Integer
With Sheets("Sheet1")
.Range("AC2:AC20753").FormulaR1C1 = _
"=IF(OR(AND(RC[-3]=""district1"", RC[2]=R2C33, RC[-18]>=1), SUM(RC[-16], RC[-14], RC[-12])>=1), 0, IF(SUM(RC[-10], RC[-8], RC[-6])>=1, 1, 0))"
For i = 2 To 632
.Range("AG" & i).Copy _
Destination:=Sheets("Sheet2").Somewhere
Sheets("Sheet2").Somewhere.Font.Bold = True
Application.Run "'Customers.xlsb'!loop1"
Next i
Next i
End Sub
I also tightened up your formula by grouping some of the conditions that would result in zero together with OR and AND functions.
The only thing remaining would be defining the Destination:=Sheets("Sheet2").Somewhere I left hanging.
I am trying to delete anything in column B that has a blank in it. A1:A10 = {3,1,10,1,1,10,2,2,2,10}. When I run my code I get a error at the delete row line. It's a "runtime 1004 error, no cells found." There clearly should have been some cells found. What is going on? I have seen some people suggest putting an On Error clause around the delete row, but that just results in nothing getting deleted.
Sub test()
Dim Total_Rows As Integer
Dim rng As Range
Total_Rows = 10
Range("B1", "B" & Total_Rows) = "=if(A1=10,"""",1)"
Range("B1", "B" & Total_Rows).Copy
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues
Set rng = Range("B1", "B" & Total_Rows)
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
You could try looping through the range like below
For Each cell In rng
If cell.Value = "" Then cell.EntireRow.Delete
Next cell
instead of finding a blank cell
Try this:
rng.AutoFilter 1, "="
rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.AutoFilterMode = False '~~> removes the filter
This filter out blanks or zero length strings then deletes it.
Or you can directly filter A1:A10 like this:
Range("A1:A10").AutoFilter 1, 10
Range("A1:A10").SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.AutoFilterMode = False