In my column A I have cells which consists of formatted dates and general formatting. I want to delete rows which are not dates, and I've made this code, but I have to run it multiple times to get it to delete all the rows which aren't dates.
Code:
Sub del_row_not_date()
Dim rng_A_last As Long
Dim i As Integer
rng_A_last = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Debug.Print rng_A_last
For i = 1 To rng_A_last Step 1
If IsDate(Sheet1.Cells(i, 1)) = False Then
Sheet1.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
Thanks in advance!
Since rows will
Based on this LINK I found this:
a tip about deleting rows based on a condition If you start at the top and work down, every time you delete a row your counter will effectively move to the cell two rows below the row you deleted because the row immediately below the deleted row moves up (i.e. it is not tested at all).
This works :)
Sub del_row_not_date()
Dim rng_A_last As Long
Dim i As Integer
rng_A_last = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Debug.Print rng_A_last
For i = rng_A_last To 1 Step -1
'Debug.Print Cells(i, 1).Value
If IsDate(Sheet1.Cells(i, 1)) = False Then
Sheet1.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
you could try
Sub del_row_not_date()
With Sheet1
.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues).EntireRow.Delete
End With
End Sub
what above deletes all column "A" not-numbers cells entire row
if you have cells with numbers that are not dates then use:
Option Explicit
Sub del_row_not_date()
Dim i As Integer
With Sheet1
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1 '<--| loop backwards not to loose next row index after deleting the current one
If Not IsDate(.Cells(i, 1)) Then .Cells(i, 1).EntireRow.Delete
Next i
End With
End Sub
Related
I am trying to delete an entire row if the values in row i column 2 and row i column 3 are empty. My for loop only iterates once. Any idea why?
Sub DeleteEm()
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To RowCount
If IsEmpty(Cells(i, 2).Value) = True And IsEmpty(Cells(i, 3).Value) = True Then
Rows(i).EntireRow.Delete
End If
Next i
End Sub
Thank you!
You have made an error which is very common for newbies in VBA. To correct the error you need to change
For i = 2 To RowCount
to
For i = RowCount to 2 Step -1
Your original code is deleting rows within the range over which you are iterating.
Consider what happens when i=4 and you delete the row corresponding to that i. Row 4 is deleted. What was row 5 now becomes row 4 BUT at the Next, i becomes 5 so i is now pointing at what was row 6 in your starting range having skipped over what was previously row 5, because that became row 4.
If you use F8 to step through your code whilst watching your sheet you will see it all happen before your eyes.
Delete Rows With Empty Cells in Two Columns
You could also consider using Application.Union to 'collect' the row ranges in a range and then delete the range in one go.
The Code
Option Explicit
Sub DeleteEm()
RowCount = Cells(Rows.Count, "A").End(xlUp).Row
Dim rng As Range
For i = 2 To RowCount
' Considering 'blank cells = empty cells + ""-cells'.
' Either (For empty cells)...
If IsEmpty(Cells(i, 2)) And IsEmpty(Cells(i, 3)) Then
' ...or (for blank cells)
'If Len(Cells(i, 2)) = 0 And Len(Cells(i, 3)) = 0 Then
If rng Is Nothing Then
Set rng = Rows(i)
Else
Set rng = Union(rng, Rows(i))
End If
End If
Next i
If Not rng Is Nothing Then
rng.Delete
End If
End Sub
in the range A1 to A70, if a cell is empty/blank then delete that entire row and move the other rows underneath up
Thank you
Use following codes.
Sub RemoveDuplicate()
On Error Resume Next
Range("A1:A70").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Edit:
Sub RemoveBlankRowsInARange()
Dim rng As Range, rws As Long, i As Long
Dim LastRow As Long
' LastRow = Cells(Rows.Count, "A").End(xlUp).Row
' Set rng = ActiveSheet.Range("A2:A" & LastRow)
' rws = rng.Rows.Count
'
' For i = rws To 1 Step (-1)
For i = 100 To 1 Step (-1)
If WorksheetFunction.CountA(Rows(i)) = 0 Then Rows(i).EntireRow.Delete
Next
End Sub
#Harun24HR - Here's how I attempted at solving this problem: I recorded a macro that deletes a row and I edited that macro to do my original question, why doesn't this work, please correct it:
Sub DeleteRowWithEmptyCell()
Dim row As Integer
For row = 1 To 100 'or whatever numbers needed
If Cells(row, 1).Value() = "" Then
Rows("row:row").Select
Selection.Delete Shift:=xlUp
End If
Next row
End Sub
Below is my source table
Name Sales
---------------------------------
Thomas 100
Jay 200
Thomas 100
Mathew 50
Output I need is as below
Name Sales
---------------------------------
Thomas 200
Jay 200
Mathew 50
Basically, I have 2 columns that can have duplicates and I need to aggregate the second column based on first column.
Current code I have is as below. Its working perfectly fine. It takes around 45 seconds to run for 4500 records. I was wondering if there is a more efficient way to do this... as it seems to be a trivial requirement.
'Combine duplicate rows and sum values
Dim Rng As Range
Dim LngRow As Long, i As Long
LngLastRow = lRow 'The last row is calculated somewhere above...
'Initializing the first row
i = 1
'Looping until blank cell is encountered in first column
While Not Cells(i, 1).Value = ""
'Initializing range object
Set Rng = Cells(i, 1)
'Looping from last row to specified first row
For LngRow = LngLastRow To (i + 1) Step -1
'Checking whether value in the cell is equal to specified cell
If Cells(LngRow, 1).Value = Rng.Value Then
Rng.Offset(0, 1).Value = Rng.Offset(0, 1).Value + Cells(LngRow, 2).Value
Rows(LngRow).Delete
End If
Next LngRow
i = i + 1
Wend
Note that this is part of a larger excel app and hence I definitely need the solution to be in Excel VBA.
Here you go:
Option Explicit
Sub Consolidate()
Dim arrData As Variant
Dim i As Long
Dim Sales As New Scripting.Dictionary 'You will need the library Microsoft Scripting Runtime
Application.ScreenUpdating = False 'speed up the code since excel won't show you what is happening
'First of all, working on arrays always speeds up a lot the code because you are working on memory
'instead of working with the sheets
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
arrData = .Range("A2", .Cells(i, 2)).Value 'here im assuming your row 1 has headers and we are storing the data into an array
End With
'Then we create a dictionary with the data
For i = 1 To UBound(arrData) 'from row 2 to the last on Q1 (the highest)
If Not Sales.Exists(arrData(i, 1)) Then
Sales.Add arrData(i, 1), arrData(i, 2) 'We add the worker(Key) with his sales(Item)
Else
Sales(arrData(i, 1)) = Sales(arrData(i, 1)) + arrData(i, 2) 'if the worker already exists, sum his sales
End If
Next i
'Now you have all the workers just once
'If you want to delete column A and B and just leave the consolidate data:
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
.Range("A2:B" & i).ClearContents
.Cells(2, 1).Resize(Sales.Count) = Application.Transpose(Sales.Keys) 'workers
.Cells(2, 2).Resize(Sales.Count) = Application.Transpose(Sales.Items) 'Their sales
End With
Application.ScreenUpdating = True 'return excel to normal
End Sub
To learn everything about dictionaries (and more) check this
With data in cols A and B like:
Running this short macro:
Sub KopyII()
Dim cell As Range, N As Long
Columns("A:A").Copy Range("C1")
ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1")
Range("D2:D" & N).Formula = "=SUMPRODUCT(--(A:A= C2),(B:B))"
End Sub
will produce this in cols C and D:
NOTE:
This relies on Excel's builtin RemoveDuplicates feature.
EDIT#1:
As chris neilsen points out, this function should be a bit quicker to evaluate:
Sub KopyIII()
Dim cell As Range, N As Long, A As Range, C As Range
Set A = Range("A:A")
Set C = Range("C:C")
A.Copy C
C.RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1") ' the header
Range("D2:D" & N).Formula = "=SUMIFS(B:B,A:A,C2)"
End Sub
So I've been searching hard to find why my code hasn't been working, but every time I try, I get a result where nothing is changed. Can someone please tell me what I'm missing? Sorry, I'm a total novice but I'm trying.
Dim Cell As Range
With Sheets(1)
' loop column D until last cell with value (not entire column)
For Each Cell In .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value <> 110 Then
Rows(Cell.Row).EntireRow.Delete
End If
Next Cell
End With
Instead of looping, make use of excels inbuilt functions, its cleaner and more concise.
With Sheets(1).UsedRange
.AutoFilter Field:=4, Criteria1:="<>110"
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
if you insist on looping then use the following code:
With Sheets(1).UsedRange
For lrow = .Rows.Count To 2 Step -1
If .Cells(lrow, 4).Value <> 110 Then .Rows(lrow).Delete
Next lrow
End With
Untested, but maybe something like:
Option explicit
Sub DeleteRows()
With thisworkbook.worksheets(1)
' loop column D until last cell with value (not entire column)
Dim lastRow as long
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Dim rowIndex as long
For rowIndex = lastRow to 2 step -1
If .cells(rowIndex, "D").value2 <> 110 then
.cells(rowIndex, "D").entirerow.delete
End if
Next rowIndex
End With
End sub
If you have a lot of rows, you could use union to build a range consisting of all rows to be deleted, then delete them in one go.
I am trying to go through row 6 and from column 1 to 26 and search for the sentence Earned Cumulative Hours. Once that is done then I am trying to go from row 8 to the last row(30 in this case) for the column that has Earned Cumulative Hours in row 6.
Then I am trying to paste the values of the cells from this column to 2 cells left in the same row. But I keep getting errors and the code doesn't work.
Can someone please point me in the right direction ? Thanks
Sub project()
Dim lastrow As Long
Dim i As Long
Dim j As Long
lastrow = Sheets("Progress").Cells(Rows.Count, 26).End(xlUp).Row
For j = 1 To 26
If Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 To lastrow
Cells(i, j).Copy
Cells(i, j).Offset(0, -2).Select
Selection.PasteSpeical Paste:=xlPasteValues
Next i
End If
Next j
End Sub
There are a few problems I can see straight away with your code. Firstly if you are offsetting back two columns .Cells(i, j).Offset(0, -2) then you will be overwriting existing values. If this is what you intend to do then weird but ok.
The next issue is that you have a problem if 'Earned Cumulative Hours' is in Column A. If this is your case Excel will be most unhappy trying to offset two columns to the left and will give an error.
In this case instead of copying and pasting it will be more efficient to set values in one column to the other which you can see in my code. Finally, your Cell references will be valid for the active sheet only. You need to qualify what worksheet you interest in as shown in my code. I normally put this at the start of the code if it is a self contained block.
You could also eliminate the i loop and set ranges of values at a time but we'll save that for next time!
I haven't test this code but it should be fine.
Sub projectawesome()
Dim lastrow as Long, i as Long, j as Long
'Qualify the sheet (assuming its in the activeworkbook)
With Sheets("Progress")
lastrow = .Cells(.Rows.Count, 26).End(xlUp).Row
'I've changed this to column three to prevent offset errors.
For j = 3 to 26
If .Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 to lastrow
'Assuming overwriting data is ok.
'No need to copy and paste
.Cells(i, j - 2).Value = .Cells(i, j).Value
Next i
End If
Next
End With
End Sub
Try this and we can get rid of those selects
Sub project()
Dim lastrow As Long
Dim i As Long
Dim j As Long
lastrow = Sheets("Progress").Cells(Rows.Count, 26).End(xlUp).Row
For j = 1 To 26
If Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 To lastrow
Cells(i, j).Copy
With Cells(i, j)
.Offset(0, -2).PasteSpecial xlPasteValues
End With
Next i ' next row
End If
Next j ' next col
End Sub