I have used a variable named rng as Range.
I have found the last row by using:
lastrow = tmpSheet.Cells(tmpSheet.Rows.Count, "A").End(xlUp).Row
& after finding a word in a Foundcell(Range format) using:
Set Foundcell = tmpSheet.Range("A2:A" & lastrow).Find(What:="ABC")
Do Until Foundcell Is Nothing
Set rng = tmpSheet.Range(Cells(1, 1), Cells(lastrow, 1))
.
.
(Copy the row from a aheet to another)
.
.
errHandler:
End Sub
After getting the value in Foundcell the control goes to End Sub directly from the line "Set rng" . I am not getting Why it's happening ?
If you are getting the range Cells(1,1) to Cells(lastrow,1) on tmpsheet, you should change the Set Rng line to:
Set rng = Range(tmpSheet.Cells(1,1), tmpSheet.Cells(lastrow,1))
instead.
You did not supply the entire code, but this is probably what you are looking for.
Sub Button1_Click()
Dim tmpSheet As Worksheet
Dim PasteSH As Worksheet
Dim lastrow As Long
Dim rng As Range
Dim c As Range
Set tmpSheet = Sheets("Sheet1")
Set PasteSH = Sheets("Sheet2")
With tmpSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & lastrow)
End With
For Each c In rng.Cells
If c = "ABC" Then
c.EntireRow.Copy PasteSH.Cells(PasteSH.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next c
End Sub
Related
Thank you in advance. New to VBA and trying to teach myself in my spare time. I am hoping someone can provide me some code to build on.
I want to loop through column K and search for each cell in columns A:I. Then I want to select the whole row and cut to another sheet. This is the code I have written, it utilized activecell but as you can imagine I would like to avoid having to click the cell I want to search for every time I execute the Macro. Especially, if I have 150 values in column K.
Sub Lineups()
Dim rng As Range
Set rng = Range("A2:I1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
ac.Interior.Color = 65535
Range("A" & ActiveCell.Row).Resize(1, 9).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
End Sub
Picture of the Data Set is below.
Data Set
Please, try the next code. Not tested, but it should work. Selecting, activating is not ta good habit. It only consumes Excel resources without bringing any benefit. Then, coloring, copying each cell/range during iteration, takes time and makes code slower. The best way is to build Union ranges and color/copy at the end of the code, at once:
Sub Lineups()
Dim ws As Worksheet, rng As Range, ac As Range, rngCol As Range
Dim lastRow As Long, rngCopy As Range, arrRng, i As Long
Set ws = ActiveSheet 'use there the sheet you want processing (probably Sheets("Data")
'lastRow = ws.Range("K" & ws.rows.count).End(xlUp).row 'the last row in column K:K
lastRow = 1501 'if you need last cell in K:K, uncomment the line above and comment this one
Set rng = ws.Range("A2:H" & lastRow)
For i = 2 To lastRow
Set ac = rng.Find(what:=ws.Range("K" & i).value, After:=ws.Range("A2"), LookIn:=xlValues, Lookat:=xlWhole)
If Not ac Is Nothing Then 'if a match has been found:
If rngCol Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCol = ws.Range("K" & i)
Else
Set rngCol = Union(rngCol, ws.Range("K" & i))
End If
If rngCopy Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCopy = ws.Range("A" & ac.row, ws.cells(ac.row, "i"))
Else
Set rngCopy = Union(rngCopy, ws.Range("A" & ac.row, ws.cells(ac.row, "i")))
End If
End If
Next i
If Not rngCol Is Nothing Then rngCol.Interior.Color = 65535 ' color the interior of the matching cells in K:K
'Copy the necessary range in sheet "Lineups" and clear the copied range:
Dim wsL As Worksheet, nextRow As Long
Set wsL = Sheets("Lineups")
nextRow = wsL.cells(rows.count, 1).End(xlUp).row + 1
If Not rngCopy Is Nothing Then 'if at least a match has been found:
rngCopy.Copy wsL.cells(nextRow, 1) 'copy the union range at once
rngCopy.ClearContents 'clear contents of the union range at once
End If
End Sub
I am leaving now my office. If something does not work as you need, or you do not understand the code, do not hesitate to ask or specify what is happening against what you need. I will be able to reply after some hours when I will be at home.
Edited:
Please, test the next version and send some feedback:
Sub Lineups_()
Dim ws As Worksheet, rng As Range, rngSearch As Range, ac As Range, rngCol As Range
Dim lastRow As Long, rngCopy As Range, rngExcl As Range, i As Long, k As Long
Set ws = ActiveSheet 'use there the sheet you want processing (probably Sheets("Data")
lastRow = ws.Range("K" & ws.Rows.Count).End(xlUp).Row 'the last row in column K:K
ws.Range("K2:K" & lastRow).Interior.Color = xlNone 'clear interior color to see the changes (you can comment it, if not necessary)
Set rng = ws.Range("A2:H1501")
Set rngSearch = rng 'set a so named search range, adapted by excluding of processed rows
For i = 2 To lastRow
Set ac = rngSearch.Find(what:=ws.Range("K" & i).Value, After:=rngSearch.Cells(1, 1), LookIn:=xlValues, Lookat:=xlWhole)
If Not ac Is Nothing Then 'if a match has been found:
If rngCol Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCol = ws.Range("K" & i)
Else
Set rngCol = Union(rngCol, ws.Range("K" & i))
End If
If rngCopy Is Nothing Then 'build the range with matching cells, to be colored at the end, at once:
Set rngCopy = ws.Range("A" & ac.Row, ws.Cells(ac.Row, "i")):
Set rngExcl = ws.Range("A" & ac.Row) 'set the range to be excluded
Else
Set rngCopy = Union(rngCopy, ws.Range("A" & ac.Row, ws.Cells(ac.Row, "i")))
Set rngExcl = Union(rngExcl, ws.Range("A" & ac.Row)) 'build the range to be excluded
End If
End If
'build the string where to search for:
Set rngSearch = InverseIntersect(rngSearch, rngExcl.EntireRow)
Next i
If Not rngCol Is Nothing Then rngCol.Interior.Color = 65535 ' color the interior of the matching cells in K:K
'Copy the necessary range in sheet "Lineups" and clear the copied range:
Dim wsL As Worksheet, nextRow As Long
Set wsL = ws.Next ' Sheets("Lineups")
nextRow = wsL.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Not rngCopy Is Nothing Then 'if at least a match has been found:
rngCopy.Copy wsL.Cells(nextRow, 1) 'copy the union range at once
rngCopy.ClearContents 'clear contents of the union range at once
End If
MsgBox "Ready..."
End Sub
Function InverseIntersect(bigRng As Range, rngExtract As Range) As Range
Dim rng As Range, rngRow As Range
For Each rngRow In bigRng.rows 'iterate between the range to be processed rows:
If Intersect(rngRow, rngExtract) Is Nothing Then 'if iterated row intersects with range to be extracted:
'creates a range only from rows which do not intersect
If rng Is Nothing Then 'Set the range as the current row
Set rng = rngRow
Else
Set rng = Union(rng, rngRow) 'creates a Union between the previous existing range and the current row
End If
End If
Next
Set InverseIntersect = rng 'set the function as the newly created range
End Function
I am looking for some assistance... Below is a code and some images of what I am attempting to acheive. I have created a selector which when you enter a qty. I want it to take the line with the quantity included and take it to another sheet on the next available line. My code is not yielding an error but neither is it doing anything at all.
I wish to take range J:P of the line with a qty entered and then paste it into the other worksheet in the next blank row of column D as there will be entries already included in A-C. Can anyone here help?
Sub Add()
Dim searchRange As Range
Dim foundCell As Range
Dim mysearch As Integer
Dim iRow As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("Output")
Set ws2 = Worksheets("Selector")
iRow = Sheets("Output").Range("D2").End(xlUp) + 1
mysearch = Sheets("Selector").Range("N10").Value
With Sheets("Selector")
Set searchRange = Sheets("Selector").Range("N12:N35") ', .Range("A" & .Rows.Count).End(xlUp))
End With
Set foundCell = searchRange.Find(what:=mysearch, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not foundCell Is Nothing Then
ws1.Cells(iRow, 4).Value = foundCell.Offset(0, -4).Value
'and so on
End If
End Sub
This is the selector
This is where I would like to paste the values (in a different order).
Try the following, I've simply amended your code slightly, and I believe it should work as expected:
Sub Add()
Dim foundCell As Range
Dim mysearch As Integer
Dim iRow As Long, Last As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("Output")
Set ws2 = Worksheets("Selector")
iRow = ws1.Cells(ws1.Rows.Count, "D").End(xlUp).Row + 1
Last = ws2.Cells(ws2.Rows.Count, "N").End(xlUp).Row
mysearch = ws2.Range("N10").Value
Set foundCell = ws2.Range("N12:N" & Last).Find(what:=mysearch, Lookat:=xlWhole)
If Not foundCell Is Nothing Then
ws1.Cells(iRow, 4).Value = foundCell.Offset(0, -4).Value
End If
End Sub
Instead of hard coding the value to be looked up ("1234"), I would like to use a range of values, on a separate worksheet("Items") to use as the search criteria.
I would also like to substitute that same value for the destination sheet.
For example, the first value in the range could be "8754", I would like the code to look for this value then paste the columns, A,B,C,F and the cell containing the value onto the worksheet "8754". (I have all of the worksheets created already)
TIA
Sub Test()
Dim Cell As Range
With Sheets("Sheet1") 'Sheet with data to check for value
For Each Cell In .Range("H1:H" & .Cells(.Rows.Count, "H").End(xlUp).Row)
pos = InStr(Cell.Value, "1234")
If pos > 0 Then
NextFreeRow = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count,
"A").End(xlUp).Row + 1
'get the next empty row to paste data to
.Range("A" & Cell.Row & ",B" & Cell.Row & ",C" & Cell.Row & ",F" &
Cell.Row & "," & Cell.Address).Copy Destination:=Sheets("Sheet2").Range("A" & NextFreeRow)
End If
Next Cell
End With
End Sub
This uses FIND rather than FILTER to copy the correct rows.
The Main procedure defines the range you're searching and which values will be searched for. The FindValues procedure finds the value and copies it to the correct sheet.
This assumes that Sheet3!A1:A3 contains a unique list of values to be searched for and the these values can be found in Sheet1!H:H.
It also assumes that all sheets already exist.
Public Sub Main()
Dim rToFind As Range
Dim rValue As Range
Dim rSearchRange As Range
With ThisWorkbook
'Update to the range being searched.
With .Worksheets("Sheet1")
Set rSearchRange = .Range("H1", .Cells(.Rows.Count, 8).End(xlUp))
End With
'Update to the range containing the values to be searched for.
Set rToFind = .Worksheets("Sheet3").Range("A1:A3")
End With
'Passe each of the values to be searched to the FindValues procedure.
For Each rValue In rToFind
FindValues rValue, rSearchRange
Next rValue
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Alternative method to look for hard-coded values.
' `ValuesToFind` in FindValues procedure will needed changing to a Variant.
'
' Dim vAlternativeSearch As Variant
' Dim vAlternativeValue As Variant
' vAlternativeSearch = Array(1475, 1683, 219)
'
' For Each vAlternativeValue In vAlternativeSearch
' FindValues vAlternativeValue, rSearchRange
' Next vAlternativeValue
End Sub
Public Sub FindValues(ValueToFind As Range, RangeToSearch As Range)
Dim rFound As Range
Dim sFirstAddress
Dim rLastUsedCell As Range
'Find the next available row on the referenced sheet.
With ThisWorkbook.Worksheets(CStr(ValueToFind))
Set rLastUsedCell = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(1)
End With
With RangeToSearch
'Find the first value.
Set rFound = .Find(What:=ValueToFind, _
After:=RangeToSearch.Cells(RangeToSearch.Cells.Count), _
LookAt:=xlPart, _
SearchDirection:=xlNext)
'If the first value exists then remember the address, copy the cells to the
'correct sheet and look for the next row with the same value. Stop when
'it reaches the first address again.
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
'You may have to muck around with this to get the correct range to copy.
'If rFound is in column H this will copy columns B:D and F.
Union(rFound.Offset(, -6).Resize(, 3), rFound.Offset(, -2)).Copy Destination:=rLastUsedCell
Set rLastUsedCell = rLastUsedCell.Offset(1)
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
End If
End With
End Sub
Edit 1:
You say the worksheets already exists, but in your comment you say put it in a brand new sheet.
To add a new sheet add this function:
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
and then add this code directly after the variable declaration in the FindValues procedure:
Dim wrkSht As Worksheet
If Not WorkSheetExists(CStr(ValueToFind)) Then
Set wrkSht = ThisWorkbook.Worksheets.Add
wrkSht.Name = CStr(ValueToFind)
End If
Edit 2:
This updated code searches columns Q:Z, returns the values from A:L as well as the found cell.
To update from the original code I had to change rSearchRange to look from Q1 to column 26, and update the Copy/Paste line to return the correct range.
Public Sub Main()
Dim rToFind As Range
Dim rValue As Range
Dim rSearchRange As Range
With ThisWorkbook
'Update to the range being searched.
With .Worksheets("Data")
Set rSearchRange = .Range("Q1", .Cells(.Rows.Count, 26).End(xlUp))
End With
'Update to the range containing the values to be searched for.
Set rToFind = .Worksheets("Items").Range("A1:A2")
End With
'Passe each of the values to be searched to the FindValues procedure.
For Each rValue In rToFind
FindValues rValue, rSearchRange
Next rValue
End Sub
Public Sub FindValues(ValueToFind As Range, RangeToSearch As Range)
Dim rFound As Range
Dim sFirstAddress
Dim rLastUsedCell As Range
'Find the next available row on the referenced sheet.
With ThisWorkbook.Worksheets(CStr(ValueToFind))
Set rLastUsedCell = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(1)
End With
With RangeToSearch
'Find the first value.
Set rFound = .Find(What:=ValueToFind, _
After:=RangeToSearch.Cells(RangeToSearch.Cells.Count), _
LookAt:=xlPart, _
SearchDirection:=xlNext)
'If the first value exists then remember the address, copy the cells to the
'correct sheet and look for the next row with the same value. Stop when
'it reaches the first address again.
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
'Parent of RangeToSeach range which will be the Data worksheet.
With .Parent
'Copy columns A:L (columns 1 to 12) and the found cell.
Union(.Range(.Cells(rFound.Row, 1), .Cells(rFound.Row, 12)), rFound).Copy Destination:=rLastUsedCell
End With
Set rLastUsedCell = rLastUsedCell.Offset(1)
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
End If
End With
End Sub
Option Explicit
Public Sub Test()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, lr1 As Long, lr2 As Long
Dim luArr As Variant, luVal As Variant, r As String, itm As Variant, itmRow As Long
Set ws1 = ThisWorkbook.Worksheets("Data") 'Sheet with data to check for value
Set ws3 = ThisWorkbook.Worksheets("Items") 'LookUp values
luArr = ws3.UsedRange.Columns("A") 'LookUp column
lr1 = ws1.Cells(ws1.Rows.Count, "H").End(xlUp).Row
Dim findRng As Range, copyRng As Range, toRng As Range, fr As Long
Set findRng = ws1.Range("H1:H" & lr1)
On Error Resume Next 'Expected error: sheet not found
Application.ScreenUpdating = False
For Each luVal In luArr
Set ws2 = Nothing
Set ws2 = ThisWorkbook.Worksheets(luVal) 'Copy to
If ws2 Is Nothing Then
Err.Clear
Else
itm = Application.Match(luVal, findRng, 0)
If Not IsError(itm) Then
findRng.AutoFilter Field:=1, Criteria1:="*" & luVal & "*"
fr = IIf(findRng.SpecialCells(xlCellTypeVisible).Cells.Count = 1, 1, 2)
With ws1.UsedRange
Set copyRng = .Range("A" & fr & ":C" & lr1)
Set copyRng = Union(copyRng, .Range("F" & fr & ":F" & lr1))
Set copyRng = Union(copyRng, .Range("H" & fr & ":H" & lr1))
End With
lr2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
copyRng.Copy
ws2.Cells(lr2, 1).PasteSpecial
findRng.AutoFilter
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Sheet1
Items
Before (Sheet A1, A2, and A3)
After
Below is the code I wrote, which deletes the rows that contain the value "PRODUCTION" in column M
Sub DeleteProducts()
Dim LR, i As Long
Dim RNG As Range
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
LR = ws.Cells(Rows.Count, "M").End(xlUp).Row
For i = LR To 2 Step -1
Select
Case ws.Cells(i, "M").Value
Case Is <> "Production"
ws.Cells(i, "M").EntireRow.Delete shift:=xlUp
End Select
Next i
Next ws
End Sub
I need rows to be deleted in multiple sheets according to the column header because column name may change (M to something else) but the header will be the same in every sheet.
I assume that the header of the column is in the first row of each worksheet:
Sub DeleteProducts()
Dim LR as Long, LC as Long, i As Long, j As Long
Dim RNG As Range
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
LC = ws.Cells(1, Columns.Count).End(xlToRight).Column
For i = LC To 2 Step -1
If ws.Cells(1, i) = "YOURnameHERE" Then
LR = ws.Cells(Rows.Count, i).End(xlUp).Row
Exit For
End If
Next
For j = LR To 2 Step -1
If ws.Cells(j, i).Value <> "Production" Then ws.Cells(j, i).EntireRow.Delete shift:=xlUp
Next
Next ws
End Sub
This will find the name of the column, and then store in i that column's number. With that information you can then find the last row of that very column, and look for every value that is not = "Production".
I also corrected some other bits of code, just for it to be cleaner.
Her is my shot at the task. The code searches for the desired header in the first row on all sheets. If the header is found, the search for "Production" continues in the column in witch the header was found.
EDIT: Did some minor cleanup of the code.
Sub DeleteRowProduction()
Dim Header As Range
Dim FoundCell As Range
Dim ws As Worksheet
Dim HeaderToFind As String
Dim ValueToFind As String
HeaderToFind = "aaa"
ValueToFind = "Production"
For Each ws In Worksheets
Set Header = ws.Rows(1).Find(what:=HeaderToFind, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not Header Is Nothing Then
Set FoundCell = ws.Columns(Header.Column).Find(what:=ValueToFind, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
Do While Not FoundCell Is Nothing
ws.Rows(FoundCell.Row).Delete
Set FoundCell = Nothing
Set FoundCell = ws.Columns(Header.Column).Find(what:=ValueToFind, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
Loop
End If
Next ws
End Sub
Please use Range.Find to find the target column. Modified your code below.
Sub DeleteProducts()
Dim LR, i As Long
Dim RNG As Range
Dim ws As Worksheet
Dim rngTargetColumn as range
For Each ws In ActiveWorkbook.Sheets
Set rngTargetColumn = ws.Range("1:1").Find("*<Column Heading>*") 'Replace <Column Heading> with your column header string
if not rngTargetColumn is Nothing then
LR = ws.Cells(Rows.Count, rngTargetColumn.Column).End(xlUp).Row
For i = LR To 2 Step -1
If ws.Cells(i, rngTargetColumn.Column).Value <> "Production" Then
ws.Cells(i, rngTargetColumn.Column).EntireRow.Delete shift:=xlUp
End If
Next i
Set rngTargetColumn = Nothing
End If
Next ws
End Sub
This is what I have already, and it works great in removing #N/As from the range. I am now looking to modify it to do the same thing for cells that contain 0.
Sub DeleteErrorRows()
Dim r As Range
Set r = Range("B:B").SpecialCells(xlCellTypeConstants, 16).EntireRow
r.Copy Sheets("Sheet2").Range("A1")
r.Delete
End Sub
Thanks :)
Try this. It autofilters your column and keeps rows that have the findMe value in your source worksheet. You can set it to 0 as I have in the example or to whatever else you want. It copies those rows (except for the header row) to the target sheet and then deletes them from the source sheet.
Note that this also finds the first empty row on the target sheet so that you can run it multiple times without overwriting what you've already moved to the target sheet.
Sub CopyThenDeleteRowsWithMatch()
Dim wb As Workbook
Dim ws As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim firstPasteRow As Long
Dim findMe As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
firstPasteRow = tgt.Range("B" & tgt.Rows.Count).End(xlUp).Row + 1
findMe = "0"
Set rng = ws.Range("B1:B" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="=" & findMe
With .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
.Copy tgt.Range("A" & firstPasteRow)
.Delete
End With
End With
' turn off the filters
ActiveSheet.AutoFilterMode = False
End Sub
Consider:
Sub DeleteZeroRows()
Dim r As Range, rTemp As Range, rB As Range
Set rB = Intersect(Range("B:B"), ActiveSheet.UsedRange)
Set r = Nothing
For Each rTemp In rB
If Not IsEmpty(rTemp) And rTemp.Value = 0 Then
If r Is Nothing Then
Set r = rTemp
Else
Set r = Union(r, rTemp)
End If
End If
Next rTemp
Set r = r.EntireRow
r.Copy Sheets("Sheet2").Range("A1")
r.Delete
End Sub