I want to delete a row within a range (not entire row) based on a criterion.
I am 90% there, however, the formatting of the data is holding me back somewhat.
The code below works well, it deletes the range ("I: Q") if the value in column "I" equals the value in cell "E2". However, there are blank rows within my data range (I: Q) that act as separators and therefore cannot be removed.
In the case of the first row being blank, the code stops and thinks it has finished its job. When actually it has done nothing.
Sub deleteb2()
Dim FindRng As Range
Dim Rng1 As Range
Dim LastRow As Long
Dim TexttoFind As Integer
Dim TexttoFind1 As String
With Sheets("DN Compile")
TexttoFind = .Range("E2").Value
later
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row '<-- get last row with
data in Column E
Set Rng1 = .Range("I1:Q" & LastRow)
Set FindRng = Rng1.Find(What:=TexttoFind, LookIn:=xlValues,
LookAt:=xlWhole)
While Not FindRng Is Nothing '<-- find was successful
FindRng.Resize(, 10).delete xlShiftUp '<-- delete column "I:Q" in
found row
Set FindRng = Rng1.Find(What:=TexttoFind, LookIn:=xlValues,
LookAt:=xlWhole)
Wend
End With
End Sub
My thinking was to somehow add an IF statement, that would cause the code to carry on looking, if for example, up to 5 consecutive blank rows are seen by the code and only then, it would stop looking further.
The code now works - I made one little adjustment and it seems to be working fine for me!
Here is what I changed:
LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row '<-- get last row with data in Column E
i.e I changed the last row line of code to count column I instead of column E.
Not sure if I should just delete the question, but thought since the code works it could be useful.
Sub deleteb2()
Dim FindRng As Range
Dim Rng1 As Range
Dim LastRow As Long
Dim TexttoFind As Integer
Dim TexttoFind1 As String
With Sheets("DN Compile")
TexttoFind = .Range("E2").Value
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row '<-- get last row with data in Column E
Set Rng1 = .Range("I1:Q" & LastRow)
Set FindRng = Rng1.Find(What:=TexttoFind, LookIn:=xlValues, LookAt:=xlWhole)
While Not FindRng Is Nothing '<-- find was successful
.Range("i" & FindRng.Row).Resize(1, 10).Delete xlShiftUp '<-- Set range based on i column.
Set FindRng = Rng1.Find(What:=TexttoFind, LookIn:=xlValues, LookAt:=xlWhole)
Wend
End With
End Sub
Related
I have a manual selection process that I have tried but failed to automate, so I am reaching out for help. I have attached an image of my Excel sheet as a visual guide when reading my process. Excel Snapshot.
I select cell "L2" and run the code below. It finds the first instance of the value within "A2:J1501" and cuts the whole row. It pastes the row onto the sheet named Lineups. Then it highlights each of the values of the cut row in column "L:L" to let me know that value has been used. I then manually select the next non-highlighted value (in the image example it would be "L2") and run the code again, and again, and again, until every row of L:L is highlighted. This process can take some time depending on the number of rows in L:L so I was hoping I can get some help to automate.
Thank you very much.
Sub ManualSelect()
Dim rng As Range
Set rng = Range("A1:J1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
Range("A" & ActiveCell.Row).Resize(1, 10).Cut
ActiveWindow.ScrollRow = 1
Sheets("Lineups").Select
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select
Dim wsData As Worksheet
Dim wsLineups As Worksheet
Dim rngToSearch As Range
Dim rngLineupSet As Range
Dim rngPlayerID As Range
Dim Column As Long
Dim Row As Long
Dim LastRow As Long
Set wsData = Sheets("Data")
Set wsLineups = Sheets("Lineups")
Set rngPlayerID = wsData.Range("L2:K200")
Set rngToSearch = rngPlayerID
LastRow = wsLineups.Cells(Rows.Count, 1).End(xlUp).Row
For Row = 2 To LastRow
For Column = 1 To 10
Set rngLineupSet = rngPlayerID.Find(what:=wsLineups.Cells(Row, Column), LookIn:=xlValues)
If Not rngLineupSet Is Nothing Then rngLineupSet.Interior.Color = 65535
Next Column
Next Row
End Sub
This should be pretty close:
Sub ManualSelect()
Dim wsData As Worksheet, c As Range, dict As Object, v, rw As Range
Dim wsLineups As Worksheet, c2 As Range, f As Range
Set dict = CreateObject("scripting.dictionary") 'for tracking already-seen values
Set wsLineups = ThisWorkbook.Worksheets("Lineups")
Set wsData = ThisWorkbook.Worksheets("Data")
For Each c In wsData.Range("L2", wsData.Cells(Rows.Count, "L").End(xlUp))
v = c.Value
If dict.exists(CStr(v)) Then
c.Interior.Color = vbYellow 'already seen this value in L or a data row
Else
'search for the value in
Set f = wsData.Range("A2:J1501").Find(v, lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
If Not f Is Nothing Then
Set rw = f.EntireRow.Columns("A").Resize(1, 10) 'A to J
For Each c2 In rw.Cells 'add all values from this row to the dictionary
dict(CStr(c2)) = True
Next c2
rw.Cut Destination:=wsLineups.Cells(Rows.Count, "A").End(xlUp).Offset(1)
c.Interior.Color = vbYellow
Else
'will there always be a match?
c.Interior.Color = vbRed 'flag no matching row
End If
End If 'haven't already seen this col L value
Next c 'next Col L value
End Sub
I believe this should do it (updated):
Sub AutoSelect()
Dim wsData As Worksheet, wsLineups As Worksheet
Dim rng As Range, listIDs As Range
Set wsData = ActiveWorkbook.Sheets("Data")
Set wsLineups = ActiveWorkbook.Sheets("Lineups")
Set rng = wsData.Range("A2:J1501")
'get last row col L to define list
LastRowL = wsData.Range("L" & Rows.Count).End(xlUp).Row
Set listIDs = wsData.Range("L2:L" & LastRowL)
'loop through all cells in list
For i = 1 To listIDs.Rows.Count
myCell = listIDs.Cells(i)
'retrieve first mach in listID
checkFirst = Application.Match(myCell, listIDs, 0)
'only check first duplicate in list
If checkFirst = i Then
'get new row for target sheet as well (if sheet empty, starting at two)
newrow = wsLineups.Range("A" & Rows.Count).End(xlUp).Row + 1
'check if it is already processed
Set processedAlready = wsLineups.Cells(2, 1).Resize(newrow - 1, rng.Columns.Count).Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'if so, color yellow, and skip
If Not processedAlready Is Nothing Then
listIDs.Cells(i).Interior.Color = vbYellow
Else
'get fist match for value, if any (n.b. "xlWhole" ensures whole match)
Set foundMatch = rng.Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'checking for a match
If Not foundMatch Is Nothing Then
'get the row
foundRow = foundMatch.Row - rng.Cells(1).Row + 1
'specify target range and set it equal to vals from correct row in rng
wsLineups.Cells(newrow, 1).Resize(1, rng.Columns.Count).Value2 = rng.Rows(foundRow).Value
'clear contents rng row
rng.Rows(foundRow).ClearContents
'give a color to cells that actually got a match
listIDs.Cells(i).Interior.Color = vbYellow
Else
'no match
listIDs.Cells(i).Interior.Color = vbRed
End If
End If
Else
'duplicate already handled, give same color as first
listIDs.Cells(i).Interior.Color = listIDs.Cells(checkFirst).Interior.Color
End If
Next i
End Sub
Also, I think, slightly faster than the other solution offered (because of the nested loop there?). Update: I got a bit confused about the nested loop in the answer by Tim Williams, but I missed that you also want to "accept" the values in the list that matched on a row that is already gone. I fixed this in the updated version by checking if a value that fails to match on the data range has already been transferred to Lineups. Provided that doing so is permissible, this method avoids the nested loop.
I checked both methods for speed (n = 50) on a list (n = 200) for the full data range, ended up with average of 1.70x faster... But maybe speed is not such a big deal, if you're coming from manual labor :)
I would like to know in vba how to count the row until a particular text "Y" is reached.
For example
I want to capture the value of the row count and use it in the for loop
For example,
For x = x-1 to ctrow
Debug.print ctrow
In the above for loop the value of ctrow should dynamically change to next row count for "Y" value once it reaches the first "Y" value. There is a "Date" field associated with the "Sample data". Once the value "Y" is matched, the date value of the "Date' field will get copied to a different workbook against same "ID" value.
It seems complicated to me. Also i found out other solution but none is working.
Also, if I need to tweak the for loop kindly let me know as well. Thanks a lot.
Sub G()
Dim rng As Range, lr, rngCopy As Range
Set rng = Range("A1").CurrentRegion
rng.Sort key1:=rng(2), Order1:=xlDescending, Header:=xlYes
lr = Columns("B:B").Find("Y", SearchDirection:=xlPrevious).Row
Set rngCopy = Range("A1:B" & lr)
'//Copy results to new sheet
With Sheets.Add(After:=Sheets(Sheets.Count))
.Cells(1).Resize(rngCopy.Rows.Count, rngCopy.Columns.Count).Value = rngCopy.Value
End With
End Sub
The code below will accomplish your full task, you must change the worksheet names, columns, and Offset to meet your specific requirements(not enough information provided). The code will first_find a "Y" value in your "Flag" column in the first worksheet. Second_it will loop through each cell in the second worksheet and compare the "ID" in the first worksheet to find a match in the second worksheet. Third_If it finds a match then it uses Offset to select the cell where you want to paste the date from the first worksheet. Then continue looping until the end. If you have problems changing the worksheet, columns, or cells references, please ask.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
Dim lRow2 As Long
lRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
Set Rng1 = ws1.Range("B2", Cells(Rows.Count, Columns("A:A").Column).End(xlUp))
Dim cel As Range
For Each cel In Rng1
If cel.Value = "Y" Then
For j = 2 To lRow2
If cel.Offset(, -1).Value = ws2.Range("A" & j).Value Then
ws2.Range("A" & j).Offset(, 3).Value = cel.Offset(, 4).Value
End If
Next j
End If
Next cel
EDIT: I may have spotted an issue as soon as posting it the myRange
variables dont seem to be doing anything - so I'm feeling they were
there from a method i was using ages ago and there decided to crop out
I'll remove the whole myRange variable and see what happens
Set myRange = ActiveSheet.Range("1:1")
Set myRange = ActiveSheet.Range("A:A")
EDIT 2: Ok so changing the numCols and numRows functions to only use
numCols = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
numRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
They now return the correct row and Column numbers
But now when I run selectBlock() it gives me runtime error 28 "Out of Stack Space"
Hello All, I've been writing code to be able to go through multiple sheets and copy the data across to a master workbook
Im coding this to work on any file depending what you pass to it - which has been fine
What im having problems with is the Functions I have made which find the last populated row for any sheet I pass to it
Sub test()
selectBlock().Select
End Sub
Function selectBlock() As Range
Dim row As Integer: row = numRows() 'Finds last populated row
Dim col As Integer: col = numCols() 'Finds last populated column
Set selectBlock() = Range("A2:" & Cells(row, col).Address)
'sets this area starting from cell A2 as the Range
End Function
Function numCols() As Integer
Dim myRange As Range
Set myRange = ActiveSheet.Range("1:1") 'Checks first row to see how many populated columns there are
numCols = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
End Function
Function numRows() As Integer
Dim myRange As Range
Set myRange = ActiveSheet.Range("A:A") 'Checks first columns to see how many populated rows there are
numRows = Range("A" & Rows.Count).End(xlUp).row
End Function
When I call the test Sub it causes Excel to hang then crash with no error code
So i imagine im creating some kind of loop or critical error that isnt handled by excel very well
Any help with this would be really appreciated
I can also understand if how im going about it is incredibly stupid
I used to code in Java and maybe im using techniques or pitfalls that I never got rid of - Im self taught at VBA like most and so never learnt official coding practices for VBA
Lot of things here
Fully qualify your cells
Use Long and not Integer when working with row and columns
Use error handling. This will avoid the Excel crashing.
Try this
Sub test()
On Error GoTo Whoa
selectBlock().Select
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Function selectBlock() As Range
Dim row As Long: row = numRows() 'Finds last populated row
Dim col As Long: col = numCols() 'Finds last populated column
Set selectBlock = ActiveSheet.Range("A2:" & ActiveSheet.Cells(row, col).Address)
End Function
Function numCols() As Long
numCols = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
End Function
Function numRows() As Long
numRows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).row
End Function
Replace
Set selectBlock() = Range("A2:" & Cells(row, col).Address)
to
Set selectBlock = Range("A2:" & Cells(row, col).Address)
it looks recursive :P
There are safer ways to find the LastRow and LastCol, I like the Find function.
See more detailed in my code's comments.
Code
Sub test()
Dim Rng As Range
Set Rng = selectBlock
Rng.Select '<-- Not sure why you need to Select ?
End Sub
'============================================================
Function selectBlock() As Range
Dim LastRow As Long
Dim LastCol As Long
LastRow = FindLastRow(ActiveSheet) 'Finds last populated row
LastCol = FindLastCol(ActiveSheet) 'Finds last populated column
Set selectBlock = Range(Cells(2, "A"), Cells(LastRow, LastCol))
End Function
'============================================================
Function FindLastCol(Sht As Worksheet) As Long
' This Function finds the last col in a worksheet, and returns the column number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastCol = LastCell.Column
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
'============================================================
Function FindLastRow(Sht As Worksheet) As Long
' This Function finds the last row in a worksheet, and returns the row number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastRow = LastCell.row
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
Hoping you can help, please!
So I have 2 worksheets, 1 & 2. Sheet1 has already existing data, Sheet2 is used to dump raw data into. This is updated daily, and the data dump includes both data from previous days, as well as new data. The new data may include rows relating to interactions that may have happened earlier in the month, not just the previous day. So the data is not "date sequential".
There are 9 columns of data, with a unique identifier in column I.
What I'm needing to happen is when running the macro, it looks in column I in Sheet1 and Sheet2, and only copies and pastes rows where the unique identifier in Sheet 2 doesn't already exist in Sheet1. And pastes them from the last empty row onwards in Sheet1.
What I currently have is this - it's all I could find online:
Sub CopyData()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundVal As Range
For Each rng In Sheets("Sheet2").Range("A1:I" & LastRow)
Set foundVal = Sheets("Sheet1").Range("I:I").Find(rng, LookIn:=xlValues, LookAt:=xlWhole)
If foundVal Is Nothing Then
rng.EntireRow.Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
End Sub
But it's just not working - not only does it not recognise if the value in column I already exists, it's copying and pasting only the first 2 rows from Sheet2, but duplicating them 8 times each!
Apologies in advance, I'm a real VBA novice, and just can't work out where it's all going wrong. I would appreciate any assistance!
This will do what you want:
Sub testy()
Dim wks As Worksheet, base As Worksheet
Dim n As Long, i As Long, m As Long
Dim rng As Range
Set wks = ThisWorkbook.Worksheets(2) 'Change "2" with your input sheet name
Set base = ThisWorkbook.Worksheets(1) 'Change "1" with your output sheet name
n = base.Cells(base.Rows.Count, "A").End(xlUp).Row
m = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
For i = 2 To m
On Error Resume Next
If IsError(WorksheetFunction.Match(wks.Cells(i, 9), base.Range("I:I"), 0)) Then
Set rng = wks.Cells(i, 1).Resize(1, 9) 'Change 9 with your input range column count
n = n + 1
base.Cells(n, 1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next i
End Sub
For a project I am working on, I am attempting to copy a row from an excel spreadsheet, only if the correct criteria are met.
For example,
I need to copy a row that has the following items in them:
Fruit, Apple, True, Cell<4
I've tried using something like
Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Set SrchRng = ActiveSheet.Range("A4:T60", ActiveSheet.Range("A60:T60").End(xlUp))
For Each strSearch In Array("Apple")
Set c = SrchRng.Find(strSearch, LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Copy
Sheets("Results").Paste
Next strSearch
End Sub
But the problem with this is that it only searches for a single criteria: Apple. I need the script to scan the whole row for all filters to be correct, then copy the row.
The script I used also only copies the row once, and does not seem to copy all rows that include Apple.
I am assuming that your data is consistent i.e. you are looking for Fruit in one column, Apple in another column and likewise for TRUE and <4.
Here in the code I am looking for Fruit in Column A, Apple in Column B, TRUE in Column C and <4 in Column D. You can change column numbers as required.
I've named the sheet where data is as Data and the sheet to paste copied rows as Results
Sub CopyRow()
Dim LastRowCurr As Long, LastRowResult As Long
Dim LastColumn As Long
Dim i As Long
Dim currWS As Worksheet, resultWS As Worksheet
Dim MyRange As Range
Set currWS = ThisWorkbook.Sheets("Data") '---> sheet where data is
Set resultWS = ThisWorkbook.Sheets("Results") '---> sheet to paste copied rows
lastRow = currWS.Cells(Rows.Count, "A").End(xlUp).Row
LastRowResult = resultWS.Cells(Rows.Count, "A").End(xlUp).Row
With currWS
For i = 4 To lastRow
'change column numbers in the below line as required
If .Cells(i, 1).Value = "Fruit" And .Cells(i, 2).Value = "Apple" And .Cells(i, 3).Value = True And .Cells(i, 4).Value < 4 Then
.Rows(i).Copy Destination:=resultWS.Range("A" & LastRowResult)
LastRowResult = LastRowResult + 1
End If
Next i
End With
End Sub
I guess this is what you want.
you have to add another loop for the .find function. On your Code it only looks once for Apples. What you have to do is, you have to add another loop and repeat the .find function until you this .find function gives your the first match again . Try something like this:
Sub Database_RoundedRectangle1_Click()
Dim c As Range, i As Long
Dim SrchRng, strSearch
Dim wsResults As Worksheet
Dim firstAddress
Set SrchRng = ActiveSheet.Range("A1:T60", ActiveSheet.Range("A60:T60").End(xlUp))
Set wsResults = ThisWorkbook.Worksheets("Results")
For Each strSearch In Array("Apple")
Set c = SrchRng.Find(strSearch, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.EntireRow.Copy wsResults.UsedRange.Cells(wsResults.UsedRange.Rows.Count + 1, 1)
Set c = SrchRng.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next strSearch
End Sub