I have the below code. I want this to delete every item in Column z that is NA... it is only deleting the first section of NA and not deleting the others. Is there something I need to add to this to get it to delete all NA's
Sub Delete_NA()
Dim LastRow As Integer
Dim x As Integer
Dim StartRow, StopRow As Integer
For x = 0 To LastRow
If (Range("Y2").Offset(x, 0) = "NA") Then
Range("Y2").Offset(x, 0).EntireRow.Delete
x = x - 1
End If
Next x
End Sub
Try with below code
Sub Delete_NA()
Dim LastRow, x As Long
LastRow = Range("Y" & Rows.Count).End(xlUp).Row
For x = LastRow To 1 Step -1
If Range("Y" & x).Value = "NA" Then
Range("Y" & x).EntireRow.Delete shift:=xlUp
End If
Next x
End Sub
Related
I have a table in an active worksheet.
I am trying to:
Scan Columns(A:M) of Row 6 to see if all cells are empty
If yes, then scan Columns (N:R) of Row 6 to see if all cells are empty
If 2. is false, then copy above row's Columns (A:I) in Row 6
Repeat 1-3 but on Row 7
This process should repeat until the rows of the table end.
I would like to incorporate ActiveSheet.ListObjects(1).Name or something similar to duplicate the sheet without having to tweak the code.
How I can make this as efficient and as risk free as possible? My code works but it's really too much.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim y As Long
Dim a As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = 0
For x = 6 To lr
For y = 1 To 13
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
If a = 0 Then
For y = 14 To 18
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
Else
a = 0
End If
If a <> 0 Then
For y = 1 To 13
Cells(x, y).Value = Cells(x - 1, y).Value
Next y
End If
a = 0
Next x
End Sub
This is the final code based on #CHill60 code. It got me 99% where I wanted.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
'check columns A to M for this row are empty
Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
'check columns N to R for this row are empty
Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
'copy the data into columns A to M
Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
r3.Value = r3.Offset(-1, 0).Value
End If
Next x
End Sub
Instead of looking at individual cells, look at Ranges instead. Consider this snippet of code
Sub demo()
Dim x As Long
For x = 6 To 8
Dim r As Range
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
Debug.Print r.Address, MyIsEmpty(r)
Next x
End Sub
I have a function for checking for empty ranges
Public Function MyIsEmpty(rng As Range) As Boolean
MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function
I use this because the cell might "look" empty, but actually contain a formula.
Note I've explicitly said which sheet I want the Cells from - users have a habit of clicking places other than where you think they should be! :laugh:
Edit after OP comment:
E.g. your function might look like this
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
a = 0
'check columns A to M for this row are empty
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
If Not MyIsEmpty(r) Then
a = a + 1
End If
If a = 0 Then
'check columns N to R for this row are empty
Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
If Not MyIsEmpty(r2) Then
a = a + 1
End If
Else
a = 0
End If
If a <> 0 Then
'copy the data into columns A to M
'You might have to adjust the ranges here
r.Value = r2.Value
End If
Next x
End Sub
where you have a source range and a target range - you appear to be putting the values in the previous row so my value of r is probably wrong in this example - you could use r.Offset(-1,0).Value = r2.Value
I'm also not sure what you are trying to do with the variable a If that is meant to be a "flag" then consider using a Boolean instead - it only has the values True or False
i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function
I'm looking for some code that will delete all rows, who's cells in columns B,C,D,E,F & G all ="0"
Many thanks for any help in advance
Give this a try:
Sub dural()
Dim N As Long, i As Long, wf As WorksheetFunction
N = Cells(Rows.Count, "B").End(xlUp).Row
Set wf = Application.WorksheetFunction
For i = N To 1 Step -1
If wf.CountIf(Range("B" & i & ":G" & i), 0) = 6 Then
Range("B" & i).EntireRow.Delete
End If
Next i
End Sub
Note:
COUNTIF() can tell the difference between a true 0 and an empty cell.
same algorithm as has been provided by Gary's Student but also has some difference, just for info:
Sub dural2()
Dim Cnt&, RowCnt&
RowCnt = Cells.Find("*", , , , , xlPrevious).Row
For Cnt = RowCnt To 1 Step -1
If Evaluate("=COUNTIF(B" & Cnt & ":G" & Cnt & ",0)") = 6 Then
Rows(Cnt).Delete
End If
Next Cnt
End Sub
As a different approach:
Sub DelLines()
Dim i As Long, j As Long, val As Variant, rng As Range
val = Intersect(ActiveSheet.UsedRange, Range("B:G")).Value
For i = 1 To Ubound(val)
For j = 1 To 6
If val(i, j) <> 0 Or Len(val(i, j)) > 0 Then Exit For
Next
If j > 6 Then
If rng Is Nothing Then
Set rng = Rows(i)
Else
Set rng = Union(rng, Rows(i))
End If
End If
Next
rng.EntireRow.Delete
End Sub
If you still have questions, just ask :)
Done by phone, may contain errors or typos
I've one workbook with 170K rows, I will delete all rows when the result between cells is 0,
For those operation, normally I use the code below, but with 170K (the rows will be deleted are 90K) the code run very slowly.
Someone know another way more performance.
Thank
Last = Cells(Rows.Count, "K").End(xlUp).Row
For i = Last To 2 Step -1
If (Cells(i, "K").Value + Cells(i, "L").Value) < 1 Then
Cells(i, "A").EntireRow.Delete
End If
Next i
As long as your fine putting the data on a new tab, the code below will do everything you need in 1.5 seconds.
Sub ExtractRows()
Dim vDataTable As Variant
Dim vNewDataTable As Variant
Dim vHeaders As Variant
Dim lastRow As Long
Dim i As Long, j As Long
Dim Counter1 As Long, Counter2 As Long
With Worksheets(1)
lastRow = .Cells(Rows.Count, "K").End(xlUp).row
vHeaders = .Range("A1:L1").Value2
vDataTable = .Range("A2:L" & lastRow).Value2
End With
For i = 1 To UBound(vDataTable)
If vDataTable(i, 11) + vDataTable(i, 12) > 0 Then
Counter1 = Counter1 + 1
End If
Next
ReDim vNewDataTable(1 To Counter1, 1 To 12)
For i = 1 To UBound(vDataTable)
If vDataTable(i, 11) + vDataTable(i, 12) > 0 Then
Counter2 = Counter2 + 1
For j = 1 To 12
vNewDataTable(Counter2, j) = vDataTable(i, j)
Next j
End If
Next
Worksheets.Add After:=Worksheets(1)
With Worksheets(2)
.Range("A1:L1") = vHeaders
.Range("A2:L" & Counter1 + 1) = vNewDataTable
End With
End Sub
Here, my approach for your problem according to rwilson's idea.
I already tested it. It very very reduce executing time. Try it.
Sub deleteRow()
Dim newSheet As Worksheet
Dim lastRow, newRow As Long
Dim sheetname As String
Dim startTime As Double
sheetname = "sheetname"
With Sheets(sheetname)
Set newSheet = ThisWorkbook.Worksheets.Add(After:=Sheets(.Name))
'Firstly copy header
newSheet.Rows(1).EntireRow.Value = .Rows(1).EntireRow.Value
lastRow = .Cells(.Rows.Count, "K").End(xlUp).row
newRow = 2
For row = 2 To lastRow Step 1
If (.Cells(row, "K").Value + .Cells(row, "L").Value) >= 1 Then
newSheet.Rows(newRow).EntireRow.Value = .Rows(row).EntireRow.Value
newRow = newRow + 1
End If
Next row
End With
Application.DisplayAlerts = False
Sheets(sheetname).Delete
Application.DisplayAlerts = True
newSheet.Name = sheetname
End Sub
Here is a non-VBA option you can try:
In column M compute the sum of columns K and L
Highlight column M and the click Find and select > Find
Type in 0 in the Find what box and also select values in the Look in box
Select Find all and in the box that shows the found items select all entires (click in the box and press CTRL + A)
On the ribbon select Delete and then Delete sheet rows
Now manually delete column M
I haven't tried this with 170k+ rows but maybe worth assessing performance versus the VBA loop.
thank at all for your ideas but the really fast code is: use an array tu populate whit the correct date and replare all table of the end sort the table:
Sub Macro13(control As IRibbonControl)
Dim avvio As Date
Dim arresto As Date
Dim tempo As Date
Application.ScreenUpdating = False
Application.Calculation = xlManual
avvio = Now()
Dim sh As Worksheet
Dim arng As Variant
Dim arrdb As Variant
Dim UR As Long, x As Long, y As Long
Dim MyCol As Integer
Set sh = Sheets("Rol_db")
MyCol = 1
sh.Select
UR = sh.Cells(Rows.Count, MyCol).End(xlUp).Row
ReDim arrdb(2 To UR, 1 To 12) As Variant
For x = 2 To UR
If Cells(x, 11) + Cells(x, 12) > 0 Then
For y = 1 To 12
arrdb(x, y) = Cells(x, y)
Next y
Else
For y = 1 To 12
arrdb(x, y) = ""
Next y
End If
Next x
sh.Range("A2:L" & UR) = arrdb
arresto = Now()
tempo = arresto - avvio
Debug.Print "Delete empty rows " & tempo
Range("A2:L" & UR).Sort key1:=Range("A2:L" & UR), _
order1:=xlAscending, Header:=xlNo
Range("A4").Select
ActiveWindow.FreezePanes = True
conclusioni:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
time for my sheet 170K 00:00:07.
as soon as I have a minute I feel a loop of the columns
I'm trying to create a macro which copies rows of data after comparing a column value. I previously asked this question but made some progress, and thought it would be less confusing if i posted another question. The column to be compared is "eRequest ID" and it consists of integers and text.
I have two worksheets, both with "eRequest ID" as the first column. The goal here is to copy ANY rows of data that has an "eRequest ID" NOT FOUND in both worksheets. Meaning if this record's "eRequest ID" is only found on one worksheet and not both, the whole row of data has to be copied into a third new worksheet.
I have worked out some codes after browsing through the net, and with the help of the coding experts here. The problem with this codes is that somehow I get a "mismatch" for every row. I tried changing the foundTrue value here and there but it doesn't seem to work. I need it to only copy rows of data with only 1 "eRequest ID" on either worksheet. Greatful for any help and appreciate your effort!
Sub compareAndCopy()
Dim lastRowE As Integer
Dim lastRowF As Integer
Dim lastRowM As Integer
Dim foundTrue As Boolean
Application.ScreenUpdating = False
lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Sheets("JULY15Release_Master Inventory").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Sheets("JULY15Release_Dev status").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Sheets("Mismatch").Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = True
For j = 1 To lastRowF
'If Sheets("JULY15Release_Master Inventory").Cells(i, 2).Value = Sheets("JULY15Release_Dev status").Cells(j, 7).Value Then
If Sheets("JULY15Release_Master Inventory").Cells(i, 2).Value <> Sheets("JULY15Release_Dev status").Cells(j, 7).Value Then
foundTrue = False
Exit For
End If
Next j
If foundTrue Then
Sheets("JULY15Release_Dev status").Rows(i).Copy Destination:= _
Sheets("Mismatch").Rows(lastRowM + 1)
lastRowM = lastRowM + 1
End If
Next i
Application.ScreenUpdating = False
End Sub
another one variant
Sub test()
Dim lastRowE&, lastRowF&, lastRowM&, Key As Variant
Dim Cle As Range, Clf As Range
Dim DicInv As Object: Set DicInv = CreateObject("Scripting.Dictionary")
Dim DicDev As Object: Set DicDev = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = 0
lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Rows.Count, "A").End(xlUp).Row
'add into dictionary row number from Inventory where cell is matched
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If Cle.Value <> "" Then
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If UCase(Cle.Value) = UCase(Clf.Value) Then DicInv.Add Cle.Row, ""
Next Clf
End If
Next Cle
'add into dictionary row number from Dev where cell is matched
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If Clf.Value <> "" Then
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If UCase(Clf.Value) = UCase(Cle.Value) Then DicDev.Add Clf.Row, ""
Next Cle
End If
Next Clf
'Get mismatch from Inventory
With Sheets("JULY15Release_Master Inventory")
For Each Cle In .Range("A1:A" & lastRowE)
If Not DicInv.exists(Cle.Row) And Cle.Value <> "" Then
.Rows(Cle.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Cle
End With
'Get mismatch from Dev
With Sheets("JULY15Release_Dev status")
For Each Clf In .Range("A1:A" & lastRowF)
If Not DicDev.exists(Clf.Row) And Clf.Value <> "" Then
.Rows(Clf.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Clf
End With
Application.ScreenUpdating = 1
End Sub
Sample
JULY15Release_Master Inventory
JULY15Release_Dev status
Output Result
Mismatch
Try this, it should work, TESTED.
Sub test()
Dim lrow1 As Long
Dim lrow2 As Long
Dim i As Long
Dim K As Long
Dim j As Long
Dim p As Variant
Dim wb As Workbook
Set wb = ThisWorkbook
K = 2
lrow1 = wb.Sheets("JULY15Release_Master Inventory").Range("A" & Rows.Count).End(xlUp).Row
lrow2 = wb.Sheets("JULY15Release_Dev status").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lrow1
p = Application.Match(wb.Sheets("JULY15Release_Master Inventory").Range("A" & i).Value, wb.Sheets("JULY15Release_Dev status").Range("A1" & ":" & "A" & lrow2), 0)
If IsError(p) Then
wb.Sheets("JULY15Release_Master Inventory").Rows(i).Copy Destination:=Sheets("Mismatch").Rows(K)
K = K + 1
End If
Next
For j = 1 To lrow2
p = Application.Match(wb.Sheets("JULY15Release_Dev status").Range("A" & j).Value, wb.Sheets("JULY15Release_Master Inventory").Range("A1" & ":" & "A" & lrow1), 0)
If IsError(p) Then
wb.Sheets("JULY15Release_Dev status").Rows(j).Copy Destination:=Sheets("Mismatch").Rows(K)
K = K + 1
End If
Next
End Sub