I am trying to delete specific rows from an excel sheet, if the data contained in a specific cell are different from their neighbors
The sheet is already sorted, as a result I can have this comparison.
The issue here is that, although a sheet around 3,000 lines would take less than a minute, when this escalates to 60,000 the function seems to never end.
Is there something wrong in what I am trying?
Is there a more efficient way?
Private Function DeleteSingleItemLines() As Long
Dim lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
lastRow = lastRow - 2
For rwIndex = 6 To lastRow
If Cells(rwIndex, "B").Value <> Cells(rwIndex + 1, "B").Value _
And Cells(rwIndex, "B").Value <> Cells(rwIndex - 1, "B").Value Then
Rows(rwIndex & ":" & rwIndex).Delete Shift:=xlUp
lastRow = lastRow - 1
rwIndex = rwIndex - 1
End If
Next rwIndex
DeleteSingleItemLines = lastRow
End Function
Well, first of all, with very small changes in your code you can make it faster by setting the property ScreenUpdating to false (write this code right after declaring variables) as in:
Application.ScreenUpdating = False
The code above keeps Excel without rendering changes in the screen and makes processing a lot faster.
Thinking about your problem in another way, you could put a formula inside your worksheet returning TRUE or FALSE for the condition you have and then use a AutoFilter to delete them all at once. It is possible to do that in vba code also.
Best regards,
Abe
Related
I have data that I am working to Parse Out that I have imported from approval emails sent in Outlook. At this point I am just importing the CreationTime and the SubjectLine.
For the subject line I am able to use the Split function to separate out most of the data. I then am left with Job Codes in Column B and Position numbers in Column C which includes the text: "Job Codes: XXXX" and the four digit job code number and "PN XXXX" and either a four digit or 6 digit position number. I am trying to use the Right functionality to loop through the entire column and reformat the column just to show only the four digit job code number for Column B and either just the 4 digit or 6 digit position number (the actual numbers) for Column C
For Job Code Column B:
Currently my code works for Shortening the Job Codes but it involves adding a column, putting the RIGHT formula in that column for the shortened Job Code, then copying and pasting the formula as values back into the column and then deleting the original column.
The problem- Works but perhaps not the most efficient with a larger data set (currently 200 rows but will have 2000 or more)
Code:
Sub ShortenJobCodes()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC3,4)"
Dim oRng As Range
Dim LastRow As Long
Range("B1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set oRng = Range("B:B")
Range(oRng, Cells(LastRow, "B")).FormulaR1C1 = R4Col
Set oRng = Nothing
Columns("B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
For Position Numbers Column C:
Currently I have mirrored the above code but added in an if statement using LEN to count if the characters are less than 8, if so then insert one RIGHT function if not insert the other RIGHT function. This also involves adding an additional column putting the RIGHT formula in that column for the shortened Position Number(Eliminating all but just the number), then copying and pasting the formula as values back into the column and then deleting the original column.
Problem - This works but seems to take forever to process and in fact looks like it is in an infinite loop. When I Esc out of it, it does add the column and then input the proper RIGHT formula (leaving just the numeric values) but the sub never seems to end, nor does it copy and paste the formulas as values or delete the original column. As noted above I realize this is likely a more efficient way to do this but I have tried a bunch of options without any luck.
I am realizing part of the loop might be due to the range itself being an entire column but I cannot find a way to stop that with the last row (even though I have a count in there).
Code:
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC4,4)"
Const R6Col = "=RIGHT(RC4,6)"
Dim oRng As Range
Dim rVal As String
Dim y As Integer
Dim selCol As Range
Dim LastRow As Long
Range("C1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = Range("D:D")
For Each oRng In selCol
oRng.Select
rVal = oRng.Value
If Len(oRng.Value) > 8 Then
oRng.Offset(0, -1).FormulaR1C1 = R6Col
Else
oRng.Offset(0, -1).FormulaR1C1 = R4Col
End If
Next
Set oRng = Nothing
Columns("C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("D1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
Major Question: Is there a way to use RIGHT/TRIM/LEN/LEFT functions to do this within a cell without having to add columns/delete columns and insert functions?
There are a few things you can do here to speed up your code. I'm only going to reference the second code block as you can apply similar logic to the first.
The first issue is that you create a LastRow variable but never reference it again. It looks like you meant to use this in the selCol range. You should change that line to Set selCol = Range("C1:C" & lastRow). This way, when you loop through the rows you only loop through the used rows.
Next, in the For-Each loop you Select every cell you loop through. There really isn't any reason to do this and takes substantially longer. You then create the variable rVal but never use it again. A better way to set up the loop is as follows.
For Each oRng in selCol
rVal = oRng.Value
If Len(rVal) > 8 Then
oRng.Value = Right(rVal, 6)
Else
oRng.Value = Right(rVal, 4)
End If
Next
This is much cleaner and no longer requires creating columns or copying and pasting.
Try this, it uses Evaluate and no loops or added columns.
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Dim selCol As Range
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = .Range(.Cells(1, 3), .Cells(LastRow, 3))
selCol.Value = .Evaluate("INDEX(IF(LEN(" & selCol.Address(0, 0) & ")>8,RIGHT(" & selCol.Address(0, 0) & ",6),RIGHT(" & selCol.Address(0, 0) & ",4)),)")
End With
Application.ScreenUpdating = True
End Sub
Or work with arrays
Sub ShortenPositionNumbers()
Dim data As Variant
Dim i As Long
With Range("C3:C" & Cells(Rows.Count, "A").End(xlUp).Row)
data = Application.Transpose(.Value)
For i = LBound(data) to UBound(data)
If Len(data(i)) > 8 Then
data(i) = RIGHT(data(i),6)
Else
data(i) = RIGHT(data(i),4)
End If
Next
.Value = Application.Transpose(data)
End With
End Sub
I am a new user of VBA and am trying to do the following (I got stuck towards the end):
I need to locate the first empty cell across every row from column C to P (3 to 16), take this value, and paste it in the column B of the same row.
What I try to do was:
Find non-empty cells in column C, copy those values into column B.
Then search for empty cells in column B, and try to copy the first non-empty cell in that row.
The first part worked out fine, but I am not too sure how to copy the first non-empty cell in the same row. I think if this can be done, I might not need the first step. Would appreciate any advice/help on this. There is the code:
Private Sub Test()
For j = 3 To 16
For i = 2 To 186313
If Not IsEmpty(Cells(i, j)) Then
Cells(i, j - 1) = Cells(i, j)
End If
sourceCol = 2
'column b has a value of 2
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell, copy the first not empty value in that row
For currentRow = 1 To RowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If Not IsEmpty(Cells(i, 3)) Or Not IsEmpty(Cells(i, 4)) Or Not IsEmpty(Cells(i, 5)) Or Not IsEmpty(Cells(i, 6)) Then
Paste
~ got stuck here
Next i
Next j
End Sub
Your loop is really inefficient as it is iterating over millions of cells, most of which don't need looked at. (16-3)*(186313-2)=2,422,043.
I also don't recommend using xlUp or xlDown or xlCellTypeLastCell as these don't always return the results you expect as the meta-data for these cells are created when the file is saved, so any changes you make after the file is saved but before it is re-saved can give you the wrong cells. This can make debugging a nightmare. Instead, I recommend using the Find() method to find the last cell. This is fast and reliable.
Here is how I would probably do it. I'm looping over the minimum amount of cells I can here, which will speed things up.
You may also want to disable the screenupdating property of the application to speed things up and make the whole thing appear more seemless.
Lastly, if you're new to VBA it's good to get in the habit of disabling the enableevents property as well so if you currently have, or add in the future, any event listeners you will not trigger the procedures associated with them to run unnecessarily or even undesirably.
Option Explicit
Private Sub Test()
Dim LastUsed As Range
Dim PasteHere As Range
Dim i As Integer
Application.ScreenUpdating=False
Application.EnableEvents=False
With Range("B:B")
Set PasteHere = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If PasteHere Is Nothing Then Set PasteHere = .Cells(1, 1) Else: Set PasteHere = PasteHere.Offset(1)
End With
For i = 3 To 16
Set LastUsed = Cells(1, i).EntireColumn.Find("*", Cells(1, i), xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
If Not LastUsed Is Nothing Then
LastUsed.Copy Destination:=PasteHere
Set PasteHere = PasteHere.Offset(1)
End If
Set LastUsed = Nothing
Next
Application.ScreenUpdating=True
Application.EnableEvents=True
End Sub
Sub non_empty()
Dim lstrow As Long
Dim i As Long
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
lstrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
For i = 1 To lstrow
If IsEmpty(Range("B" & i)) Then
Range("B" & i).Value = Range("B" & i).End(xlToRight).Value
End If
Next i
End Sub
I'm working with big worksheet containing stocks information, with columns organized like this :
ID DATE TIME PRICE QUANTITY NBE
It goes on for 500k+ rows, and I have 10+ sheets to go through. I need to extract only the first two trade of each trading day, and create a new list on a new sheet (Sheet1). The first trade of every day is always at "09:00:00".
So far I wrote this piece of code, in which I tried to copy the two lines I need and then paste them into Sheet1 thus creating the new list. It runs without errors, but nothing shows up...
Sub Macro1()
i = 2
Range("C2").Select
Range(Selection, Selection.End(xlDown)).Select
For Each Cell In Selection
If Day(.Range("B" & cRow).Value) <> Day(.Range("B" & cRow - 1).Value) Then
ActiveCell.EntireRow.Copy
ActiveWorkbook.Sheets("Sheet1").Rows(i).Paste
ActiveCell.Offset(1).Copy
ActiveWorkbook.Sheets("Sheet1").Rows(i + 1).Paste
i = i + 2
End If
Next Cell
End Sub
Shouldn't i select and the copy paste the two rows together? Or is it possible to create a range consisting of 2 rows and 6 columns from the activecell and then copy paste that range?
EDIT 1: It's not working.. I updated it like above, but I still get an error 438 here ActiveWorkbook.Sheets("Sheet1").Rows(i).Paste
EDIT 2: I'm def a big noob. Just realized not every first trade was made at 9:00:00 so i need to select the row based on wether or not one day have passed, and select the first two.
Can I use this condition instead : If Day(Range("B" & cRow).Value) <> Day(Range("B" & cRow - 1).Value) Then ?
I'm betting that your Time column is formatted as a Date/Time field, so you're comparing a string 09:00:00 to a long (date/time) and it's never going to be equal.
Try this:
if Format(Cell.Value, "hh:mm:ss") = "09:00:00" Then
And your English isn't bad at all...
This should do it quickly
make sure your on the sheet with data and run it, and it will copy it onto sheet1 in the same workbook starting at row2
you should make sure sheet1 is empty also , with .clearContents
Sub Macro1()
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim cRow As Long
Dim shSrc As Worksheet
Dim lngNextDestRow As Long
Dim shDest As Worksheet
Application.ScreenUpdating = False
Set shSrc = ActiveWorkbook.ActiveSheet
Set shDest = ActiveWorkbook.Sheets("Sheet1")
With shSrc
lngFirstRow = 2
lngLastRow = .Cells.Find(What:="*", After:=.Cells.Cells(1), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
lngNextDestRow = 2
For cRow = lngFirstRow To lngLastRow Step 1
If Format(.Range("C" & cRow).value, "hh:mm:ss") = "09:00:00" Then
.Rows(cRow).EntireRow.Copy Destination:=shDest.Range("A" & lngNextDestRow )
.Rows(cRow+1).EntireRow.Copy Destination:=shDest.Range("A" & lngNextDestRow+1 )
lngNextDestRow = lngNextDestRow + 2
End If
Next cRow
End With
Application.ScreenUpdating = True
End Sub
When you refrence a sheet using the following line
ActiveWorkbook.Sheets(Sheet1).Rows(i).Paste
Sheet1 is likely a variable that is not defined properly. If "Sheet1" is the actual name of the sheet then enclose it in doublequotes
ActiveWorkbook.Sheets("Sheet1").Rows(i).Paste
After looking at #FreeMan's answer....you should do that first. You'll probably get an error 9 subscript error after you fix what he said to do.
I'm new to VBA and I have recently been creating a few macros. I currently have one that works, but it isn't very cooperative at times. I've done a bunch of reading on how to optimize VBA code, but I'm still not getting very far. I understand using Select is bad, and I've removed as much of the Select lines as I could on my own. I've also read that many if statements combined with loops can be hard to run as well (of course I have multiples of both).
So I know some of the reasons why my code is bad, but I don't really know how to fix it. I added
Application.ScreenUpdating = False
Application.ScreenUpdating = True
to my macro as well. This has helped, but not much. I have other macros that can run for a long time and never freeze up. This macro freezes if it doesn't finish in 10-15 seconds. If I only have a couple 100 rows of data it runs no problem. If I have a few 1000 lines of data it doesn't finish before it freezes.
Option Explicit
Sub FillGainerPrices()
Application.ScreenUpdating = False
'Search each name on "Gainer Prices" and if the same name is on "Gainers", but not on Gainer Prices _
move it over to Gainer Prices tab. Then call Historical Query and Fill Names
Dim LastRow1 As Long
LastRow1 = Sheets("Gainers").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim LastRow2 As Long
LastRow2 = Sheets("Gainer Prices").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim Name1 As Range
Dim Name2 As Range
For Each Name1 In Sheets("Gainers").Range("B2:B" & LastRow1)
Set Name2 = Sheets("Gainer Prices").Range("A2:A" & LastRow2).Find(Name1, LookIn:=xlValues, LookAt:=xlWhole)
If Name2 Is Nothing Then
If Name1.Offset(0, -1) < Date - 15 Then
Name1.Copy
Sheets("Gainer Prices").Select
Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).Select
ActiveSheet.Paste
Call HistoricalQuery
End If
End If
Next Name1
Application.ScreenUpdating = True
'Fill in Names and remaining symbols here
Call FillNamesAndSymbols
End Sub
Call HistoricalQuery and Call FillNamesAndSybmols are pretty quick and do not seem to have any issues when I run them by themselves so I don't think they are causing the problem. I'm guessing the issue is searching for one Name 1000's of times and then copying and pasting over and over, but I can't figure out how to get rid of the copy and paste part without the macro giving me wrong results.
The end goal of the macro is to go to the 2nd sheet and see if those names are on the first sheet. If not, it moves the names over, and then for each name it moves over it calls another macro to pull historical data for that name. Finally at the end it just does some formatting and filling in or deleting of blank cells. If anyone can direct me in the correct direction I would appreciate it. Thanks!
Try this code.
Improvments:
Timing: my code: 0.8828125 sec, your code: 10.003 sec. (tested with 1000 rows in both sheets)
I'm using array to store values from second sheet: arr = Sheets("Gainer Prices").Range("A2:A" & LastRow2).Value - much faster for huge data
I'm using Application.Match instead Range.Find - it's faster as well.
I'm using Range(..).Value = Range(..).Value instead copy/paste
avoid using select/active statement
Sub FillGainerPrices()
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim Lastrow3 As Long
Dim Name1 As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim arr As Variant
'remember start time
Dim start as Long
start = Timer
Application.ScreenUpdating = False
Set sh1 = ThisWorkbook.Sheets("Gainers")
Set sh2 = ThisWorkbook.Sheets("Gainer Prices")
With sh1
LastRow1 = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
With sh2
LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = .Range("A2:A" & LastRow2).Value
End With
For Each Name1 In sh1.Range("B2:B" & LastRow1)
If IsError(Application.Match(Name1.Value, arr, 0)) Then
If Name1.Offset(0, -1) < Date - 15 Then
With sh2
Lastrow3 = .Cells(.Rows.Count, "C").End(xlUp).Row
.Range("A" & Lastrow3 + 1).Value = Name1.Value
End With
Call HistoricalQuery
End If
End If
Next Name1
'Fill in Names and remaining symbols here
Call FillNamesAndSymbols
Application.ScreenUpdating = True
'To see timing result press CTRL+G in the VBE window, or change Debug.Print to MsgBox
Debug.Print "Code evaluates for: " & Timer - start
End Sub
instead of
Name1.Copy
Sheets("Gainer Prices").Select
Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).Select
ActiveSheet.Paste
you might try something like this:
Name1.copy destination:=Sheets("Gainer Prices").Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2)
or perhaps
Sheets("Gainer Prices").Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).value=Name1.value
Edited
this is the code that answers the question
Dim i As Integer
For i = 1 To Sheet1.UsedRange.Rows.Count
If Cells(i, "C") <> "Q" Then
Sheet1.Rows(i).EntireRow.Copy Sheets("Sheet2").Cells(i, 1)
End If
Next
edit2
I'm now facing minor problems it would be great to figure out what's wrong with them.
1- This code is copying the cells but the problem is after pasting them in the other sheet there is gaps all over the place (they are the places of non-copied cells)
Dim i As Integer
For i = 1 To Sheet1.UsedRange.Rows.Count
If Cells(i, "P") <> "Q" Then
Sheet1.Rows(i).EntireRow.Copy Sheets("Sheet2").Cells(i, 1)
End If
Next
the fix for this problem is to add
.End(xlUp).Offset(1, 0)
after the line that does the copy and pasting. I tried that before but i used Offset(1) and that didn't work
2-This code causes Excel to hang and i have to force it to close but when i reopen it the copied cells are there in the new sheet(i kind of know the problem, i think it's because Excel will check all cells since they are = 0 but i tried using the same for loop as the previous code but i kept getting errors)
Dim ro As Long
For Each cell In Sheets("Sheet1").range("U:U")
If (Len(cell.Value) = 0) Then
ro = (ro + 1)
Sheets("Sheet1").Rows(cell.Row).Copy Sheets("Sheet3").Rows(ro)
End If
Next
the fix for #2 is to add a for loop of the rows count and include it, i knew that would fix it but i had problems with the syntax. The code needed the change in this line:
For Each cell In Sheets("Sheet1").range("U" & i)
"i" being the for loop, just like the one in code #1
This code will iterate all of your rows in Column A and check if the text is a Q, W or E. If it isn't it'll copy that row.
Sub Test()
Dim i As Integer
'Loop to move through the rows
For i = 1 To ActiveSheet.UsedRange.Rows.Count
'Checks if it contains Q, W or E
If Cells(i, 1) <> "Q" And Cells(i, 1) <> "W" And Cells(i, 1) <> "E" Then
'Copy that row
Rows(i).Copy
'You said you know how to do the copy part so I won't include the rest...
Else
'Do something else
End If
Next
End Sub
Next time actually attempt the problem before asking for help. If it weren't so simple, people probably wouldn't help out too much. This is also something which is a quick google or SO search away.
AutoFilter does this quickly by avoiding loops, and will avoid the gaps on the rows copy
If you do have lower case q or w data then an advanced filter using EXACT will be needed on the output in the second sheet. See Debra's example here
Sub Clean()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
Set rng1 = ws1.Range(ws1.[a1], ws1.Cells(Rows.Count, "A").End(xlUp))
With rng1
.AutoFilter Field:=1, Field:=1, Criteria1:="<>Q", Operator:=xlAnd, Criteria2:="<>W"
If rng1.Cells.Count > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy ws2.[a1]
End With
ws1.AutoFilterMode = False
End Sub