I have a worksheet that contains some merged data from two different sources. There is one common/shared column - time/date.
Columns B-E contain data when columns F-G do not, and vice versa.
What I want to do, is go down column F, when I find a value, I want to go to column E and work up until I find a value. At that point, I want to check its value - if it is less than 4, then I want to delete the row that originally triggered the column E lookup.
Then, continue going down. I probably will need to do this in reverse (starting at the bottom, and working my way up) due to things I've found in the past, but am not sure yet.
So, my code that I'm working on right now is as follows - it doesn't work correctly, and I'm trying to troubleshoot it to make it work correctly, but am having difficulty. Any information/advice/help you could provide would be greatly appreciated.
Set myrange = Sheets("Test Sheet").Range("F2", Range("F" & Rows.Count).End(xlUp))
For Each mycell In myrange
rrow = rrow + 1
If IsEmpty(mycell.Value) = False Then
For j = rrow To 0 Step -1
If IsEmpty(mycell.Offset(j, -1)) = False And mycell.Cells(j, -1).Value < 4 Then
mycell.Cells(rrow, -1).EntireRow.Delete
GoTo line
Else
End If
Next j
line:
Else
End If
Next mycell
Try this out:
Sub DeleteRows()
Dim ColFRow As Long
Dim ColERow As Long
Dim ToDelete As Range
For ColFRow = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If (Not IsEmpty(Cells(ColFRow, 6).Value)) Then
For ColERow = ColFRow To 0 Step -1
If (Not IsEmpty(Cells(ColERow, 5).Value)) Then
If Cells(ColERow, 5).Value > 4 Then
If ToDelete Is Nothing Then
Set ToDelete = Cells(ColFRow, 1).EntireRow
Else
Set ToDelete = Union(ToDelete, Cells(ColFRow, 1).EntireRow)
End If
End If
Exit For
End If
Next ColERow
End If
Next ColFRow
ToDelete.Delete
End Sub
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've built this code, and it's working fine. However I expect there must be a more elegant way to embed the range 'c' into the Evaluate function rather than how I've used 'r' to determine the row number, and build that into the reference.
(I'm learning). Copy of (very stripped down) xlsm available here: https://www.dropbox.com/s/e6pcugqs4zizfgn/2018-11-28%20-%20Hide%20table%20rows.xlsm?dl=0
Sub HideTableRows()
Application.ScreenUpdating = False
Dim c As Range
Dim r As Integer
For Each c In Range("ForecastTable[[Group]:[Item]]").Rows
r = c.Row
If Application.Evaluate("=COUNTA(B" & r & ":D" & r & ") = 0") = True Then
c.EntireRow.Hidden = True
Else: c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
There's no specific question/problem, but here's my suggested code improvements.
Most notably, I wouldn't execute the Hidden procedure until you have all the rows. That way you don't have repeatedly do something that only need be completed once. This will always be the best practice when looping and manipulating data. Make changes to the sheet AFTER you have identified the range.
With the above change, you don't need to turn off ScreenUpdating.
The Evaluate function is fine, but isEmpty is probably the best option. There are probably slightly faster methods, perhaps checking multiple if-statements, but that's getting into fractions of a second over thousands of rows (probably not worth researching).
Technically you don't really need to loop by rows. You can get by with a single cell in a row, then checking the next two over, see utilization of Offset to generate that range. This also creates a more dynamic than using hard-coded columns ("A"/"B"...etc")
Long is recommended over Integer but this is pretty small, and I'm only mentioning it because I posted about it here.. Technically you don't even need it with the above changes.
Here's the code:
Sub HideTableRows()
Dim c As Range, hIdeRNG As Range, WS As Worksheet
'based on OP xlsm file.
Set WS = Sheet4
'used range outside of used range to avoid an if-statement on every row
Set hIdeRNG = WS.Cells(Rows.Count, 1)
'loops through range of single cells for faster speed
For Each c In Range("ForecastTable[Group]").Cells
If IsEmpty(Range(c, c.Offset(0, 2))) = 0 Then
'only need a single member in the row.
Set hIdeRNG = Union(hIdeRNG, c)
End If
Next c
'Hides rows only if found more than 1 cell in loop
If hIdeRNG.Cells.Count > 1 Then
Intersect(WS.UsedRange, hIdeRNG).EntireRow.Hidden = True
End If
End Sub
Final Thought: There's some major enhancements coming out to Excel supposedly in early 2019 that might be useful for this type of situation if you were looking for a non-VBA solution. Click here for more info from MS.
Flipping the logic a bit, why not just filter those three columns for blanks, then hide all the visible filtered blank rows in one go?
Something like this:
Sub DoTheHide()
Dim myTable As ListObject
Set myTable = Sheet4.ListObjects("ForecastTable")
With myTable.Range
.AutoFilter Field:=1, Criteria1:="="
.AutoFilter Field:=2, Criteria1:="="
.AutoFilter Field:=3, Criteria1:="="
End With
Dim rowsToHide As Range
On Error Resume Next
Set rowsToHide = myTable.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
myTable.AutoFilter.ShowAllData
If Not rowsToHide Is Nothing Then
rowsToHide.EntireRow.Hidden = True
End If
End Sub
Since c is used to iterate over the rows and each row contains the 3 cells in question ("=COUNTA(B" & r & ":D" & r & ") = 0") is equivalent to ("=COUNTA(" & c.Address & ") = 0"). But using the WorksheetFunction directly is a better appraoch.
It should be noted that Range("[Table]") will return the proper result as long as the table is in the ActiveWorkbook. It would be better to useThisWorkbook.Worksheets("Sheet1").Range("[Table]")`.
Sub HideTableRows()
Application.ScreenUpdating = False
Dim row As Range, target As Range
With Range("ForecastTable[[Group]:[Item]]")
.EntireRow.Hidden = False
For Each row In .rows
If Application.WorksheetFunction.CountA(row) = 0 Then
If target Is Nothing Then
Set target = row
Else
Set target = Union(target, row)
End If
End If
Next
End With
If Not target Is Nothing Then target.EntireRow.Hidden = True
Application.ScreenUpdating = True
End Sub
I'm trying to check the contents of the cells in column Q and delete the rows that have a 0 in that column.
The macro should start checking in column Q at cell Q11 and stop when it encounters the cell containing the text "END". When finished it should select the cell at the upper left corner of the spreadsheet, which would normally be A1, but I have a merged cell there, so it's A1:K2.
Here are my two most recent versions of the macro:
'My second to last attempt
Sub DeleteRowMacro1()
Dim i As Integer
i = 11
Do
Cells(i, 17).Activate
If ActiveCell.Value = 0 Then
ActiveCell.EntireRow.Delete
End If
i = i + 1
Loop Until ActiveCell.Value = "END"
Range("A1:K2").Select
End Sub
'My last attempt
Sub DeleteRowMacro2()
Dim i As Integer
i = 11
GoTo Filter
Filter:
Cells(i, 17).Activate
If ActiveCell.Value = "END" Then GoTo EndingCondition
If ActiveCell.Value = "" Then GoTo KeepCondition
If ActiveCell.Value = 0 Then GoTo DeleteCondition
If ActiveCell.Value > 0 Then GoTo KeepCondition
EndingCondition:
Range("A1:K2").Select
KeepCondition:
i = i + 1
GoTo Filter
DeleteCondition:
ActiveCell.EntireRow.Delete
i = i + 1
GoTo Filter
End Sub
What DeleteRowMacro1() Does:
It leaves the row if there is text or a number greater than 0 in column Q, but it deletes the rows with cells with a 0 AND blank cells. I want to keep the rows with the blank cells.
This macro seems to be incapable of checking the 450 or so cells between the Q11 and the cell with "END" in one run. It only deletes about half of the rows it should each time. The first 10 or so rows are always done correctly, but then it appears to randomly choose rows with a zero or a blank in column Q to delete.
If I run the macro 7 or 8 times, it will eventually delete all of the rows with a 0 and the ones that are blank too. I would like it to completely do it's job in one run and not delete the rows with blank cells.
What DeleteRowMacro2() Does:
It never stops at "END".
I have to run it 7 or 8 times to completely get rid of all of the rows with a 0 in column Q. It also appears to randomly check cells for deletion (and once again besides the first 10 or so).
Because it never ends when I run it, the area of my screen where the spreadsheet is turns black and all I can see there is the green selected cell box flickering up and down at random locations in the Q column until it gets to a row number in the 32,000s. After that my screen returns to show the normal white spreadsheet and a box appears that says Run-time error '6': Overflow.
Please note: After I click "End" on the error box I can see that the macro worked as described above.
Try it as,
Option Explicit
Sub DeleteRowMacro3()
Dim rwend As Variant
With Worksheets("Sheet5")
If .AutoFilterMode Then .AutoFilterMode = False
rwend = Application.Match("end", .Range(.Cells(11, "Q"), .Cells(.Rows.Count, "Q")), 0)
If Not IsError(rwend) Then
With .Range(.Cells(10, "Q"), .Cells(rwend + 10, "Q"))
.AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=vbNullString
With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
End With
End With
End If
.Activate
.Range("A1:K2").Select
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I wasn't sure if you were looking specifically for zeroes or zero value so I included blank cells as well as numerical zeroes.
First, it's best practice to avoid using .Select/.Activate. That can cause some confusion and tricky writing when doing loops/macros in general.
Second, it's also best to avoid GoTo.
This macro will start at the last row in column Q, and make its way toward row 11. If the value of a cell is 0, it'll delete the row. If the value is END, it selects your range and exits the For loop, and then exits the sub.
Sub delRows()
Dim lastRow As Long, i As Long
Dim ws as Worksheet
Set ws = Worksheets("Sheet1") ' CHANGE THIS AS NECESSARY
lastRow = ws.Cells(ws.Rows.Count, 17).End(xlUp).Row
For i = lastRow To 11 Step -1
If ws.Cells(i, 17).Value = "END" Then
ws.Range("A1:K2").Select
Exit For
End If
If ws.Cells(i, 17).Value = 0 or ws.Cells(i, 17).Value = "0" Then
ws.Cells(i, 17).EntireRow.Delete
End If
Next i
End Sub
Try this variation of your first code:
Sub DeleteRowMacro1()
Dim i As Integer
i = 11
Do
Cells(i, 17).Activate
If IsEmpty(ActiveCell.Value) Then
ActiveCell.EntireRow.Delete
End If
If ActiveCell.Value = "END" Then
Exit Do
End If
i = i + 1
Loop
Range("A1:K2").Select
End Sub
Try this simpler, and faster version. It will locate all of the cells you want to delete, store them in a range object, and then delete them all at once at the end.
Public Sub DeleteRowsWithRange()
Dim rngLoop As Range
Dim rngMyRange As Range
For Each rngLoop In Columns("Q").Cells
If rngLoop.Value = "END" Then
Exit For
ElseIf rngLoop.Value = 0 Then
If rngMyRange Is Nothing Then
Set rngMyRange = rngLoop.EntireRow
Else
Set rngMyRange = Union(rngMyRange, rngLoop.EntireRow)
End If
End If
Next rngLoop
If Not rngMyRange Is Nothing Then rngMyRange.Delete xlShiftUp
Range("A1").Activate
Set rngLoop = Nothing
Set rngMyRange = Nothing
End Sub
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
End Sub
I'm not new to Excel VBA but not an expert too. I'm in strange problem, someone plz help me I'm not able to think anymore.
My Excel Story:
I have some 40,000 rows in a spreadsheet. rows are in the pattern mentioned as below:
row1) Source > AppName1
row2) Destination > corresponding value1
row3) Destination > corresponding value2
row4) Source > AppName2
row5) Destination > corresponding value3
row6) Source > AppName3
row7) Destination > corresponding value1
Now if search by AppName let's be AppName1 then row2 and row3 should be copied to next sheet along with row1.
If I search for Value1 then it should get row1, row2, row3 row7 and row6 should be copied to next sheet. That means search strings precedents and descendent's rows should be copied to next sheet.
I cannot provide the sample sheet as my reputation points are less than 10.
Is there anyone who can guide and assist me I have spent my 3 days in this but not got any result.
I have a very critical schedule for preparing this inventory sheet I was doing it manually and it was taking 5-6days to do manually. I thought of automizing it but got stuck.
Here is my code that is not working:
Sub GenerateInventory()
On Error GoTo ErrHandler:
Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
Set r1 = Cells(2, 8)
For i = 2 To nLastRow Step 1
If InStr(Cells(i, 6), "CMRI") <> 0 Then
Set r1 = Union(r1, Cells(i, 1))
End If
Next
r1.EntireRow.Select
r1.EntireRow.Copy
Sheets("MS4Inventory").Select
Cells(100, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Exit Sub
ErrHandler:
MsgBox Err.Number & ": " & Error.Description
End Sub
This code is not upto the mark still in WIP.
Your example data and requirements are difficult to understand.
I've modified your code a little, which may help you to progress.
If you can post a snippet of your data and the required result we can progress further
Sub GenerateInventory()
Dim r As Range, r1 As Range, rMS4Inventory As Range
Dim nLastRow As Long, i As Long
Dim wb As Workbook, sh As Worksheet, shMS4Inventory As Worksheet
On Error GoTo ErrHandler:
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set shMS4Inventory = wb.Worksheets("MS4Inventory")
Set r = sh.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
Set r1 = sh.Cells(2, 8)
For i = 2 To nLastRow Step 1
If InStr(sh.Cells(i, 6), "CMRI") <> 0 Then
Set r1 = Union(r1, sh.Cells(i, 1))
End If
Next
Set rMS4Inventory = shMS4Inventory.Cells(100, 1).End(xlUp).Offset(1, 0).EntireRow
r1.EntireRow.Copy rMS4Inventory
Exit Sub
ErrHandler:
Resume
MsgBox Err.Number & ": " & Error.Description
End Sub
before going to the coding, let's grab the problem ....
you want to search for anything in the sheet, and return the three rows that belong to the "paragraph" where your search landed
Under the assumption that ALL paragraphs are TRIPLES, all the rows that mark the beginning of a "paragraph" have the same property: rownumber modulo 3 has the same constant value. So in whatever rownumber your search lands, you need to go back until rownumber modulo 3 gets equal your constant value. Having arrived there, you play out 3 rows - and stop
now coding should become pretty simple .... you fire a search or place the cursor "somewhere" by other means, and fire the Sub Grab()
Sub Grab3Rows()
Dim Idx As Long
Idx = Selection.Row
'find start of paragraph
Do While Idx Mod 3 <> 2 ' change this constant as per your sheet
Idx = Idx - 1
Loop
'select the 3 cells at the start of paragraph
Selection.Offset(Idx - Selection.Row, 0).Resize(3, 1).Select
'do the rest
End Sub
Under the assumption that paragraphs are n-tuples AND contain the string "Source" at the first line, you can do something similar: Whereever your search lands, you go back row by row until you arrive at a row containing string "Source", from there you play out rows until you again reach a row containing "Source"
Sub GrabByTextString()
Dim Idx As Long
Idx = Selection.Row
'find start of paragraph
Do While Left(Selection.Offset(Idx - Selection.Row, 0), 6) <> "Source"
Idx = Idx - 1
Loop
'select the the start of paragraph
Selection.Offset(Idx - Selection.Row, 0).Select
'expand selection until we reach next paragraph start
Idx = 1
Do While Left(Selection(1, 1).Offset(Idx, 0), 6) <> "Source"
Idx = Idx + 1
Selection.Resize(Idx, 1).Select
Loop
'do the rest
End Sub