I'm trying to clear the contents of any cells within a column that contain the numbers 1-12. I'm currently using a for loop and an if statement, going one at a time through the numbers 1-12 and clearing the contents if the cell contains those values. The file I'm working with has over 35,000 rows of data; is there a more efficient way to tell the macro to delete those numbers without creating an individual elseif statement for them?
For r = 2 To i
If Cells(r, 1).Value = "1" Then
Cells(r, 1).ClearContents
ElseIf Cells(r, 1).Value = "2" Then
Cells(r, 1).ClearContents
You can use comparison operators combined with an And:
For r = 2 to i
If Cells(r, 1).Value >= 1 And Cells(r, 1).Value <= 12 Then
Cells(r, 1).ClearContents
End If
Next
Use a filter:
Sub tgr()
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
With ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
.AutoFilter 1, ">=1", xlAnd, "<=12"
.Offset(1).ClearContents
.AutoFilter
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Related
I am running the following code on a spreadsheet:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
End If
i = i + 1
Loop
There are plenty of entries with not "String" but they do not get deleted.
When I copy this piece of code to a separate sheet, I even get the error "Excel cannot complete this task with available resources. Choose less data or close other applications."
What am I doing wrong that is making this loop not work?
Note: I can't use autofilter because I need to delete rows based on not meeting a condition.
This is the worst way to delete a row. Reasons
You are deleting the rows in a Loop
Your Cells Object are not qualified
Try this.
Co-incidentally I answered a similar question in the MSDN forum as well. Please See THIS
Try this way (UNTESTED)
In the below code I have hardcoded the last row to 100000 unlike as done in the above link.
Sub Sample()
Dim ws As Worksheet
Dim i As Long
Dim delRange As Range
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
For i = 1 To 100000
If .Cells(i, 4).Value <> "String" Then
If delRange Is Nothing Then
Set delRange = .Rows(i)
Else
Set delRange = Union(delRange, .Rows(i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Delete
End With
End Sub
NOTE: I am assuming that a cell will have values like
String
aaa
bbb
ccc
String
If you have scenarios where the "String" can be in different cases or in between other strings for example
String
aaa
STRING
ccc
dddStringddd
then you will have to take a slightly different approach as shown in that link.
Autofilter code:
Sub QuickCull()
Dim rng1 As Range
Set rng1 = Range([d4], Cells(Rows.Count, "D").End(xlUp))
ActiveSheet.AutoFilterMode = False
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
With rng1
.AutoFilter Field:=1, Criteria1:="<>string"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then _
.Offset(1, 0).Resize(rng1.Rows.Count - 1).Rows.Delete
End With
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
ActiveSheet.AutoFilterMode = False
End Sub
When you want to delete rows its always better to delete from bottom.
Sub DeleteData()
Dim r As Long
Dim Rng As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("sheet1")
Set Rng = .Range(.Range("D1"), .Range("D1").End(xlDown))
For r = Rng.Rows.Count To 1 Step -1
If LCase(Trim(.Cells(r, 4).Value)) <> LCase("string") Then
.Cells(r, 4).EntireRow.Delete
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
This is a basic algorithm mistake.
Imagine your program are on, say, row 10. You delete it. So, row 11 becomes row 10, row 12 becomes 11 and so on. Then you go to row 11, skipping row 10, previous row 11!
This would work:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
Else
i = i + 1
End If
Loop
So I have a code that conducts a loop on Vlookup and the intention of this is that based on the vlookup, it moves specific cells over to another specific cell but in another sheet. The code runs but it does not move the data over for some reason. I've tried another approach within the If comment and doing a range with a copy destination but I begin to get object not identified errors. Hoping someone can see what I may be missing on why the values are not getting moved over.
Dim i, j, lastG, lastD As Long
Dim sht, ws As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
' find last row
lastG = Sheets("Log").Cells(Rows.Count, "B").End(xlUp).Row
lastD = Sheets("Slide Layout").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Row
Set sht = Sheets("Log")
Set ws = Sheets("Slide Layout")
' loop over values in "Log"
For i = 2 To lastG
currVal = ws.Cells(Rows.Count, "J").End(xlUp)
lookupval = Sheets("Log").Cells(i, "B") ' value to find
If lookupval = currVal Then
sht.Cells(i, "F") = ws.Cells(lastD)
End If
Next i
On Error Resume Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With
End Sub
Not sure if i am following entirely...but it looks like you should have this
sht.Cells(i, "F") = currVal
Update, figured it out! I just replaced the
sht.Cells(i, "F") = ws.Cells(lastD)
with
sht.Cells(i, "F").Copy Destination:=ws.Cells(lastD, "B")
I appreciate the help.
The following code checks to see if any of my rows on the main page contain a date from a year ago or older. If it does, it copies it to the "Archive" worksheet and deletes it from the main page. However, what it's doing now is just copying from the main page and overriding what already exists on the archive page instead of adding to the last row. I've tried subbing in LastRow from a function, but I was getting an error with how I was using it. Anyone have a better solution?
Sub TestDateTransfer()
With Application
PrevCalc = .Calculation
.Calculation = xlCalculationManual
.Cursor = xlWait
.Calculate
.EnableEvents = False
.ScreenUpdating = False
End With
Application.DisplayAlerts = False
Worksheets("Archive").Activate
Range("A3:I1000").Select
Selection.ClearContents
Worksheets("Main Page").Activate
Dim MyDate As Date
MyDate = "03/27/2017"
Set i = Sheets("Main Page")
Set E = Sheets("Archive")
Dim d
Dim j
d = 2
j = 2
Do Until IsEmpty(i.Range("C" & j))
If i.Range("C" & j) <= MyDate - 365 Then
d = d + 1
E.rows(d).Value = i.rows(j).Value
End If
j = j + 1
Loop
Worksheets("Archive").Activate
ActiveSheet.Range("H1").Select 'To unselect the page
Worksheets("Main Page").Activate
MyDate = "03/27/2017"
Dim y
Dim z
y = 2
z = 2
Do Until IsEmpty(i.Range("C" & z))
If i.Range("C" & z) <= MyDate - 365 Then
y = y + 1
i.rows(z).Delete
End If
z = z + 1
Loop
With Application
.Cursor = xlDefault
.Calculate
.Calculation = PrevCalc
'.ScreenUpdating = True 'Not Needed...
.EnableEvents = True
End With
ActiveSheet.Range("H1").Select
End Sub
Worksheets("Archive").Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = "hai"
I have written a small piece of code that shows you how to use this. My code is different than yours b/c it loops through the range and checks each cell if the value of the difference between it and NOW is greater than or equal to 1 (which is how to tell if its from lats year or not). Its not how you approach it but it does seem to be more simplified in the approach. Alsoe I soted a bucnh of dates in a spreadsheet and tested this out. just apply to your needs. I hope this helps more?
Private Sub this()
Dim rng As Range
Dim rcell As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:A20")
For Each rcell In rng.Cells
'note that if you dont put a handler in here to deal with blank cells values this code will run forever. most peop-le do a check with "if rcell.valeu <> vbNullString then etc etc
If DateDiff("yyyy", rcell.Value, Now()) >= 1 Then
Worksheets("Sheet2").Cells(Sheet2.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = rcell.Value
rcell.Value = vbNullString
End If
Next rcell
End Sub
You could exploit AutoFilter() method of Range object and copy/paste filtered rows in one shot:
Option Explicit
Sub main()
Dim MyDate As Date
MyDate = "03/27/2017"
Dim E As Worksheet
Set E = Worksheets("Archive")
With Worksheets("Main Page")
With .Range("C1", .Cells(.Rows.Count, "C").End(xlUp))
.AutoFilter field:=1, Criteria1:="<=" & CDbl((MyDate - 365))
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy Destination:=E.Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
.AutoFilterMode = False
End With
End Sub
I have a table in which I want to create a VBA code to write me the dates In ascending order in horizontally method but the problem when I activate the code, it gives me the date with the last criteria. my code is as follows:
Private Sub Worksheet_Activate()
Dim a As Range, ab As Range, b As Range, bc As Range
Set ab = Range("B3:E3")
Set bc = Range("A2:D2")
For Each a In ab
For Each b In bc
If Cells(3, 1) <> "" Then
Cells(3, a.Column) = Range("A3") + Cells(2, b.Column)
Else
Cells(3, a.Column) = ""
End If
Next
Next
End Sub
yes, I changed the Ranges identification names, but the most important part is the solution.
Private Sub Worksheet_Activate()
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim cng As Range, rng As Range
Set rng = Range("B3:E3")
For Each cng In rng
If Cells(3, 1) <> "" Then
cng.Offset(0, 0).Value = cng.Offset(0, -1) + 1
ElseIf Cells(3, 1) = "" Then
cell.Offset(0, 5).Value = ""
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I am running the following code on a spreadsheet:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
End If
i = i + 1
Loop
There are plenty of entries with not "String" but they do not get deleted.
When I copy this piece of code to a separate sheet, I even get the error "Excel cannot complete this task with available resources. Choose less data or close other applications."
What am I doing wrong that is making this loop not work?
Note: I can't use autofilter because I need to delete rows based on not meeting a condition.
This is the worst way to delete a row. Reasons
You are deleting the rows in a Loop
Your Cells Object are not qualified
Try this.
Co-incidentally I answered a similar question in the MSDN forum as well. Please See THIS
Try this way (UNTESTED)
In the below code I have hardcoded the last row to 100000 unlike as done in the above link.
Sub Sample()
Dim ws As Worksheet
Dim i As Long
Dim delRange As Range
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
For i = 1 To 100000
If .Cells(i, 4).Value <> "String" Then
If delRange Is Nothing Then
Set delRange = .Rows(i)
Else
Set delRange = Union(delRange, .Rows(i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Delete
End With
End Sub
NOTE: I am assuming that a cell will have values like
String
aaa
bbb
ccc
String
If you have scenarios where the "String" can be in different cases or in between other strings for example
String
aaa
STRING
ccc
dddStringddd
then you will have to take a slightly different approach as shown in that link.
Autofilter code:
Sub QuickCull()
Dim rng1 As Range
Set rng1 = Range([d4], Cells(Rows.Count, "D").End(xlUp))
ActiveSheet.AutoFilterMode = False
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
With rng1
.AutoFilter Field:=1, Criteria1:="<>string"
If rng1.SpecialCells(xlCellTypeVisible).Count > 1 Then _
.Offset(1, 0).Resize(rng1.Rows.Count - 1).Rows.Delete
End With
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
ActiveSheet.AutoFilterMode = False
End Sub
When you want to delete rows its always better to delete from bottom.
Sub DeleteData()
Dim r As Long
Dim Rng As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("sheet1")
Set Rng = .Range(.Range("D1"), .Range("D1").End(xlDown))
For r = Rng.Rows.Count To 1 Step -1
If LCase(Trim(.Cells(r, 4).Value)) <> LCase("string") Then
.Cells(r, 4).EntireRow.Delete
End If
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
This is a basic algorithm mistake.
Imagine your program are on, say, row 10. You delete it. So, row 11 becomes row 10, row 12 becomes 11 and so on. Then you go to row 11, skipping row 10, previous row 11!
This would work:
Do While i <= 100000
If Not Cells(i, 4) = "String" Then
Cells(i, 4).EntireRow.Delete
Else
i = i + 1
End If
Loop