I have a worksheet in Excel where the E column contains the velocity of a vehicle. The first few rows have 0 velocity until the vehicle starts moving. I want to find the range of rows at the start of the sheet where the vehicle is in idle and remove them, as I have no real reason to keep these rows
I found this code to find the range of rows where a specific text is stored in one of the cells:
Private Sub DeleteIdleRows()
Dim idleStartRow as Long, idleEndRow as Long
With ActiveSheet
idleStartRow = .Range("E:E").Find(what:="0", after:=.Range("E3")).Row
idleEndRow = .Range("E:E").Find(what:="0", after:=.Range("E3"), searchdirection:=xlPrevious).Row
End With
End Sub
The code gives no errors, but it finds the absolute last instance of 0, and not the last 0 in the first "set". Is there a way for me to narrow down this search function to stop as soon as the next instance is not 0?
Option Explicit
Private Sub DeleteIdleRows()
Dim idleStartRow As Long
Dim idleEndRow As Long
Dim i As Long
idleStartRow = 0
With ActiveSheet
For i = 1 To Cells(Rows.Count, "E").End(xlUp).Row
If Range("E" & i).Value2 = 0 And idleStartRow = 0 And IsEmpty(Range("E" & i).Value2) = False Then idleStartRow = i
If Range("E" & i + 1).Value <> 0 And idleStartRow <> 0 Then
idleEndRow = i
Exit For
End If
Next
End With
MsgBox idleStartRow
MsgBox idleEndRow
End Sub
I have modified your code little bit and is working fine. Also note that in your formula when you are using find function, it will also return the row even if the value contains zero (Example: 30)
Related
I have written a short VBA code to copy rows from one worksheet "Quote Tracker", to another sheet "Cashflow", once a certain value has been selected in Column "O" (75 - 100%).
The issue I am having is that the rows are not copied into the next available empty row, only further down the sheet. I am also unable to stop the code copying the same line multiple times.
Is there anything I can add to ensure they are always added to the top of the "Cashflow" sheet or next available row?
I am also unable to put anything together to detect duplicates, so if the code is run more than once, it just keeps adding them to the "Cashflow sheet". Can anything be added to stop this?
Here is what I have so far:
Sub MoveRowBasedOnCellValue()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Quote Tracker").UsedRange.Rows.Count
J = Worksheets("Cashflow").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Cashflow").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Quote Tracker").Range("O1:O" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "75 - 100%" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Cashflow").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Jobs copied to Cashflow tab"
End Sub
If you require more information, please, just let me know. I'm new here and trying to make a good impression.
I have compiled a sub that will suit your needs. The first issue I saw was your use of "On Error resume Next". This will make it nearly impossible to debug your code because the code will not tell you if there is an error it will simply skip over it. The second issue I was able to see was that you made the problem more complex than necessary. You used a For To loop where a For Each loop would get the job done more easily. I have added in a piece of code which makes the cell in the "P" column of the row with a value over 75% "Transferred" once it has been copied to the "Cashflow" sheet. The code also checks if "Transferred" is present in that column and if it is, it skips that value. Additionally, the code checks if J is 1 which would be the first value copied, and if it is not one then it adds one to the counter so that it does not paste on top of the row above.
Sub MoveRowBasedOnCellValue()
Dim QTWs As Worksheet
Dim CWs As Worksheet
Set QTWs = Worksheets("Quote Tracker")
Set CWs = Worksheets("Cashflow")
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = QTWs.UsedRange.Rows.Count
J = CWs.Cells(Rows.Count, "O").End(xlUp).Row
If J <> 1 Then
J = J + 1
End If
Set xRg = QTWs.Range("O1:O" & I)
Application.ScreenUpdating = False
For Each c In xRg
K = c.Row
If c.Value < 0.75 Then
'Do Nothing
Else
If QTWs.Cells(K, 16) <> "Transferred" Then
QTWs.Rows(K).Copy Destination:=Worksheets("Cashflow").Range("A" & J)
QTWs.Cells(K, 16).Value = "Transferred"
J = J + 1
Else
'Do Nothing
End If
End If
Next
Application.ScreenUpdating = True
MsgBox "Jobs copied to Cashflow tab"
End Sub
If you have questions about how it works, do not hesitate to let me know. Hope this helps!
I have a problem...
I have two datasets in the same workbook on different sheets.
The first column in both datasets are identifiers. In Sheet1 I have my dataset, and want to fill it with data from Sheet2 (which is also containing data (rows+Columns) that I do not want to use.
I have a VBA that is working, BUT, it stops before it is done.
E.g. I have 1598 Rows in Sheet2, but it stops working already after 567 rows..
Sub Test()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("Sheet2")
Set Target = ActiveWorkbook.Worksheets("Sheet1")
j = 2
For Each c In Source.Range("A2", Source.Range("A" & Source.Cells(Source.Rows.Count, "A").End(xlUp).Row))
If c = Target.Cells(j, 1).Value Then
Source.Range("D" & c.Row & ":AS" & c.Row).Copy Target.Cells(j, 26)
j = j + 1
End If
Next c
MsgBox "Done"
End Sub
Can someone help me and see if there is something obviously wrong with the code? I have tried it on smaller datasets, and then it works perfect.
If more information needed or you have some other tips, please ask/tell :D
Thanks!
VBA Solution
Try the following, it usese the WorksheetFunction.Match method to properly match the values of column A no matter which order they are.
It loops through all rows in Target, and tries to find a matching row in Source. If a match was found it copies it into the Target.
Option Explicit
Public Sub Test()
Dim Source As Worksheet
Set Source = ThisWorkbook.Worksheets("Sheet2")
Dim Target As Worksheet
Set Target = ThisWorkbook.Worksheets("Sheet1")
Dim LastRowTarget As Long
LastRowTarget = Target.Cells(Target.Rows.Count, "A").End(xlUp).Row
Dim tRow As Long
For tRow = 2 To LastRowTarget
Dim sRowMatch As Double
sRowMatch = 0 'reset match row
On Error Resume Next 'ignore if next line throws error
sRowMatch = Application.WorksheetFunction.Match(Target.Cells(tRow, 1).Value, Source.Columns("A"), 0)
On Error GoTo 0 're-enable error reporting
If sRowMatch <> 0 Then 'if matching does not find anything it will be 0 so <>0 means something was found to copy
Source.Range("D" & sRowMatch & ":AS" & sRowMatch).Copy Target.Cells(tRow, 26)
End If
Next tRow
MsgBox "Done"
End Sub
Formula Solution
Note that there is no need for VBA and this could actually also solved with formulas only. Either the VLOOKUP formula or a combination of INDEX and MATCH formula.
So in Sheet1 cell Z2 write =INDEX(Sheet2!D:D,MATCH($A2,Sheet2!$A:$A, 0)) and pull it down and right.
Looking for the best way to write the following code. I am currently struggling to make my code as simple and neat as possible. The code effectively takes a range and returns back the range which is non-empty.
Option Explicit
Sub ReturnNonEmptyRange()
Dim testBool As Boolean
Dim i As Long
testBool = True
For i = 2 To 10000:
If Range("G" & i) = "" Then
i = i - 1
testBool = False
End If
If testBool = False Then
Exit For
End If
Next i
MsgBox ("The range is G2:K" & i)
End Sub
Below is some sample code you can try.
The function LastUsedRow is not used, but I'm providing since it can be useful. This will return the last used row in your worksheet.
Using "Range" like you did above will assume you want to use active sheet. I always like to specify a workbook and a sheet so there is no ambiguity.
Sub Test()
' Start at row 1 and and stop when first blank cell found
Dim wks As Worksheet: Set wks = ThisWorkbook.Worksheets("Sheet1")
Dim row As Long
' Option 1: using column numbers
row = 1
Dim col As Long: col = 7 ' G
Do Until wks.Cells(row + 1, col).Value = ""
row = row + 1
Loop
MsgBox ("Last used row (in column): " & row) ' assumes something in row 1
' Option 2: using column letters
row = 1
Dim colLetter As String: colLetter = "G"
Do Until wks.Range(colLetter & row + 1).Value = ""
row = row + 1
Loop
MsgBox ("Last used row (in column): " & row) ' assumes something in row 1
End Sub
Public Function LastUsedRow(wks As Worksheet) As Long
Dim rng As Range: Set rng = wks.UsedRange ' Excel will recalc used range
LastUsedRow = rng.row + rng.Rows.Count - 1
End Function
I think your method only works if your none-empty range is consecutive. Suppose G2:G10 is non-empty, G11 is empty and G12:G20 is non-empty. Your code would come to i=11 and return G2:K10 as the non-empty range.
A more reliable, and quicker way to find the last non-empty cell (before row 1000) would be this:
range("G1000").End(xlUp).row
This will give you the first non-empty row in column G above row 1000. If row 1000 is non-empty however, it would search upwards for the last non-empty row. so you might want to change it to:
Range("G" & Rows.Count).End(xlUp).Row
This will find the last non-empty row, starting from the bottom of the worksheet.
How about combining the loop's exit conditions all into the loop control header.
I also would explicitly access the range()'s value to be more clear in the code and check the string length to be zero.
Option Explicit
Sub ReturnNonEmptyRange()
Dim testBool As Boolean
Dim i As Long
testBool = True
i = 2
While (i < 10000) And (Len(Range("G" & i).Value) <> 0)
i = i + 1
Wend
MsgBox ("The range is G2:K" & i)
End Sub
In the case this was an Array, one could not use Range("G" & Rows.Count).End(xlUp).Row. I believe #Siddharth provided a good solution. The downside being it will stop at a non- empty row.
Sub ReturnNonEmptyRange()
Dim i As Long
For i = 2 To 10000:
If Len(Trim(Range("G" & i).Value)) = 0 Then Exit For
Next i
MsgBox ("The range is G2:K" & i - 1)
End Sub
I have an excel file which looks like this:
row1_cell1 row1_cell2 row1_cell3
row2_cell1 row2_cell2 row2_cell3
row3_cell1 row3_cell2 row3_cell3
How can i make three (or any number of) copies of each row that i have in the sheet, which i would like to be added after the row being copied? So, in the end i would like to have this kind of a result:
row1_cell1 row1_cell2 row1_cell3
row1_cell1 row1_cell2 row1_cell3
row1_cell1 row1_cell2 row1_cell3
row2_cell1 row2_cell2 row2_cell3
row2_cell1 row2_cell2 row2_cell3
row2_cell1 row2_cell2 row2_cell3
row3_cell1 row3_cell2 row3_cell3
row3_cell1 row3_cell2 row3_cell3
row3_cell1 row3_cell2 row3_cell3
This is how I would do that for all rows on the sheet:
Option Explicit
Sub MultiplyRows()
Dim RwsCnt As Long, LR As Long, InsRw As Long
RwsCnt = Application.InputBox("How many copies of each row should be inserted?", "Insert Count", 2, Type:=1)
If RwsCnt = 0 Then Exit Sub
LR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For InsRw = LR To 1 Step -1
Rows(InsRw).Copy
Rows(InsRw + 1).Resize(RwsCnt).Insert xlShiftDown
Next InsRw
Application.ScreenUpdating = True
End Sub
There isn't a direct way to paste them interleaved like what you wanted. However, you can create a temporary VBA to do what you want.
For example, you can:-
Create a VBA procedure (like the one below) in your Excel file.
Assign a keyboard shortcut (eg. Ctrl+Q) to it.
To do this, press Alt+F8, then select the macro, then click 'Options'.
Select the cells you want to copy, then press Ctrl+C.
Select the cell you want to paste in, then press Ctrl+Q (or whatever keyboard shortcut you chose).
Enter the number of times you want to copy. (In your example, it would be 3.)
WHAMMO! :D
Now you can delete the VBA procedure. :)
VBA Code:
Sub PasteAsInterleave()
Dim startCell As Range
Dim endCell As Range
Dim firstRow As Range
Dim pasteCount As Long
Dim rowCount As Long
Dim colCount As Long
Dim i As Long
Dim j As Long
Dim inputValue As String
If Application.CutCopyMode = False Then Exit Sub
'Get number of times to copy.
inputValue = InputBox("Enter number of times to paste interleaved:", _
"Paste Interleave", "")
If inputValue = "" Then Exit Sub 'Cancelled by user.
On Error GoTo Error
pasteCount = CInt(inputValue)
If pasteCount <= 0 Then Exit Sub
On Error GoTo 0
'Paste first set.
ActiveSheet.Paste
If pasteCount = 1 Then Exit Sub
'Get pasted data information.
Set startCell = Selection.Cells(1)
Set endCell = Selection.Cells(Selection.Cells.count)
rowCount = endCell.Row - startCell.Row + 1
colCount = endCell.Column - startCell.Column + 1
Set firstRow = Range(startCell, startCell.Offset(0, colCount - 1))
'Paste everything else while rearranging rows.
For i = rowCount To 1 Step -1
firstRow.Offset(i - 1, 0).Copy
For j = 1 To pasteCount
startCell.Offset(pasteCount * i - j, 0).PasteSpecial
Next j
Next i
'Select the pasted cells.
Application.CutCopyMode = False
Range(startCell, startCell.Offset(rowCount * pasteCount - 1, colCount - 1)).Select
Exit Sub
Error:
MsgBox "Invalid number."
End Sub
Old thread, however someone might find this useful:
The below information was copied from here
I needed to do almost the opposite. I needed the formula to increment by 1 every 22 rows, leaving the 21 rows between blank. I used a modification of the formula above and it worked great. Here is what I used:
=IFERROR(INDIRECT("J"&((ROW()-1)*1/22)+1),"")
The information was in column "J".
The "IFERROR" portion handles the error received when the resulting row calculation is not an integer and puts a blank in that cell.
Hope someone finds this useful. I have been looking for this solution for a while, but today I really needed it.
Thanks.
UPDATE:
Alright, so i used the following code and it does what i need it to do, i.e check if the value is 0 and if its is, then delete the entire row. However i want to do this to multiple worksheets inside one workbook, one at a time. What the following code is doing is that it removes the zeros only from the current spreadsheet which is active by default when you open excel through the VBA script. here the working zero removal code:
Dim wsDCCTabA As Excel.Worksheet
Dim wsTempGtoS As Excel.Worksheet
Set wsDCCTabA = wbDCC.Worksheets("Login")
Set wsTempGtoS = wbCalc.Worksheets("All_TemporaryDifferences")
Dim LastRow As Long, n As Long
LastRow = wsTempGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If Cells(n, 5).Value = 0 Then
Cells(n, 5).EntireRow.Delete
End If
Next
What am i doing wrong? when i do the same thing for another worksheet inside the same workbook it doesnt do anything. I am using the following code to remove zeros from anohter worksheet:
Set wsPermGtoS = wbCalc.Worksheets("All_PermanentDifferences")
'delete rows with 0 description
Dim LastRow As Long, n As Long
LastRow = wsPermGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If Cells(n, 5).Value = 0 Then
Cells(n, 5).EntireRow.Delete
End If
Next
Any thoughts? or another way of doing the same thing?
ORIGINAL QUESTION:
I want to delete all the rows which have a zero in a particular column. I am using the following code but nothing seems to happen:
CurrRow = (Range("E65536").End(xlUp).Row)
For Count = StartRow To CurrRow
If wsDCCTabA.Range("E" & Count).Value = "0" Then
wsDCCTabA.Rows(Count).Delete
End If
Next
StartRow contains the starting row value
CurrRow contains the row value of the last used row
See if this helps:
Sub DelSomeRows()
Dim colNo As Long: colNo = 5 ' hardcoded to look in col 5
Dim ws As Worksheet: Set ws = ActiveSheet ' on the active sheet
Dim rgCol As Range
Set rgCol = ws.Columns(colNo) ' full col range (huge)
Set rgCol = Application.Intersect(ws.UsedRange, rgCol) ' shrink to nec size
Dim rgZeroCells As Range ' range to hold all the "0" cells (union of disjoint cells)
Dim rgCell As Range ' single cell to iterate
For Each rgCell In rgCol.Cells
If Not IsError(rgCell) Then
If rgCell.Value = "0" Then
If rgZeroCells Is Nothing Then
Set rgZeroCells = rgCell ' found 1st one, assign
Else
Set rgZeroCells = Union(rgZeroCells, rgCell) ' found another, append
End If
End If
End If
Next rgCell
If Not rgZeroCells Is Nothing Then
rgZeroCells.EntireRow.Delete ' deletes all the target rows at once
End If
End Sub
Once you delete a row, u need to minus the "Count" variable
CurrRow = (Range("E65536").End(xlUp).Row)
For Count = StartRow To CurrRow
If wsDCCTabA.Range("E" & Count).Value = "0" Then
wsDCCTabA.Rows(Count).Delete
' Add this line:
Count = Count - 1
End If
Next
I got it. For future reference, i used
ActiveWorkbook.Sheets("All_temporaryDifferences").Activate
and
ActiveWorkbook.Sheets("All_Permanentdifferences").Activate
You don't need to use ActiveWorkbook.Sheets("All_temporaryDifferences").Activate. In fact if the ActiveWorkbook is different from wbCalc you would get an error.
Your real problem is that you are using an unqualified reference to Cells(n, 5).Value. Unqualified means that you aren't specifying which sheet to use so it defaults to the active sheet. That may work sometimes but it is poor code. In your case it didn't work.
Instead you should always use qualified references. wsTempGtoS.Cells(n, 5).Value is a qualified reference. wsTempGtoS specifies which worksheet you want so VBA is not left guessing.
Dim LastRow As Long, n As Long
LastRow = wsTempGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If wsTempGtoS.Cells(n, 5).Value = 0 Then
wsTempGtoS.Cells(n, 5).EntireRow.Delete
End If
Next
This: CurrRow = (Range("E65536").End(xlUp).Row) is also an unqualified reference. Instead it should be CurrRow = wsDCCTabA.Range("E65536").End(xlUp).Row.