I'm trying to adapt the Sub + Function from this thread to my need:
write all possible combinations
Tim Williams solution.
It works fine since all columns have at least 2 values. I'm after if there is a workaround to make it work even if some of the columns have just one value in it.
In the Sub command I could change to
col.Add Application.Transpose(sht.Range(Cells(3, c.Column), Cells(Rows.Count, c.Column).End(xlUp)))
and it goes fine.
But the Function is crashing at this line:
ReDim pos(1 To numIn)
just when processing the column that has just one value in it.
Thaks in advance for any help.
I have a more elegant solution with following assumptions:
The data and write to cells are on the same activesheet
Start combination from a cell you specify and going downward then right
Stops going rightward as soon as the cell of the same row is empty
writes the combination from a cell you specify going downwards
Screenshots after the code (Bug fixed on 1 row only on a data column):
Private Const sSEP = "|" ' Separator Character
Sub ListCombinations()
Dim oRngTopLeft As Range, oRngWriteTo As Range
Set oRngWriteTo = Range("E1")
Set oRngTopLeft = Range("A1")
WriteCombinations oRngWriteTo, oRngTopLeft
Set oRngWriteTo = Nothing
Set oRngTopLeft = Nothing
End Sub
Private Sub WriteCombinations(ByRef oRngWriteTo As Range, ByRef oRngTop As Range, Optional sPrefix As String)
Dim iR As Long ' Row Offset
Dim lLastRow As Long ' Last Row of the same column
Dim sTmp As String ' Temp string
If IsEmpty(oRngTop) Then Exit Sub ' Quit if input cell is Empty
lLastRow = Cells(Rows.Count, oRngTop.Column).End(xlUp).Row
'lLastRow = oRngTop.End(xlDown).Row ' <- Bug when 1 row only
For iR = 0 To lLastRow - 1
sTmp = ""
If sPrefix <> "" Then
sTmp = sPrefix & sSEP & oRngTop.Offset(iR, 0).Value
Else
sTmp = oRngTop.Offset(iR, 0).Value
End If
' No recurse if next column starts empty
If IsEmpty(oRngTop.Offset(0, 1)) Then
oRngWriteTo.Value = sTmp ' Write value
Set oRngWriteTo = oRngWriteTo.Offset(1, 0) ' move to next writing cell
Else
WriteCombinations oRngWriteTo, oRngTop.Offset(0, 1), sTmp
End If
Next
End Sub
Related
I want my code to go through a list of cells containing names and split them up into the cells next to the original. I have some basic code to do the first bit, but I'm struggling to get it to cycle through the rest of my list, and also outputting it next to the original rather than in A1 as it does currently. I presume it's an issue with the 'Cell' part of the code but I can't quite fix it.
Sub NameSplit()
Dim txt As String
Dim i As Integer
Dim FullName As Variant
Dim x As String, cell As Range
txt = ActiveCell.Value
FullName = Split(txt, " ")
For i = 0 To UBound(FullName)
Cells(1, i + 1).Value = FullName(i)
Next i
End Sub
Use a For Each loop on the range of name values. In this case, I just assumed they were in the first column but you can adjust accordingly:
Sub NameSplit()
Dim txt As String
Dim i As Integer
Dim FullName As Variant
Dim x As String, cell As Range
For Each cell In ActiveSheet.Range(Cells(1,1),Cells(ActiveSheet.UsedRange.Count,1))
txt = cell.Value
FullName = Split(txt, " ")
For i = 0 To UBound(FullName)
cell.offset(0,i + 1).Value = FullName(i)
Next i
Next cell
End Sub
Make sure you are not trying to Split a blank cell and write all of the values in at once rather than nest a second For ... Next Statement.
Sub NameSplit()
Dim var As Variant
Dim rw As Long
With Worksheets("Sheet1") '<~~ you should know what worksheet you are on!!!!
'from row 2 to the last row in column A
For rw = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
'check to make the cell is not blank
If CBool(Len(.Cells(rw, "A").Value2)) Then
'split on a space (e.g. Chr(32))
var = Split(.Cells(rw, "A").Value2, Chr(32))
'resize the target and stuff the pieces in
.Cells(rw, "B").Resize(1, UBound(var) + 1) = var
End If
Next rw
End With
End Sub
If you are simply splitting on a space, have you considered a Range.TextToColumns method?
Sub NameSplit2()
Dim var As Variant
Dim rw As Long
'disable overwrite warning
Application.DisplayAlerts = False
With Worksheets("Sheet1") '<~~ you should know what worksheet you are on!!!!
'from row 2 to the last row in column A
With .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
'Text-to-Columns with space delimiter
.TextToColumns Destination:=.Cells(1, 2), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
Tab:=False, Semicolon:=False, Comma:=False, Other:=False, _
Space:=True
End With
End With
Application.DisplayAlerts = True
End Sub
One method is to combine a do loop with a for loop.
Do loops are a great way to iterate over items, when you are not sure at the outset how many items there are. In this case you may have more names during one execution than the next.
For loops are handy when you know in advance how many items you will be looping over. In this case we know at the start of the loop how many elements are in our names array.
The code below starts with the active cell and works its way down, until it finds an empty cell.
Sub SplitName()
' Splits names into columns, using space as a delimitor.
' Starts from the active cell.
Dim names As Variant ' Array. Holds names extracted from active cell.
Dim c As Integer ' Counter. Used to loop over returned names.
' Keeps going until the active cell is empty.
Do Until ActiveCell.Value = vbNullString
names = Split(ActiveCell.Value, Space(1))
' Write each found name part into a seperate column.
For c = LBound(names) To UBound(names)
' Extract element to an offset of active cell.
ActiveCell.Offset(0, c + 1).Value = names(c)
Next
ActiveCell.Offset(1, 0).Select ' Move to next row.
DoEvents ' Prevents Excel from appearing frozen when running over a large number of items.
Loop
End Sub
There are several ways you could improve this proceedure.
As a general rule automation is more robust when it avoids objects like ActiveCell. This is because the user could move the active cell while your code is executing. You could refactor this procedure to accept a source range as a parameter. You could then build another sub that calculates the source range and passes it to this sub for processing. That would improve the reusability of SplitName.
You could also look into Excels Text to Columns method. This could potentially produce the desired result using fewer lines of code, which is always good.
Text to Columns would be a great way to do this if you can. If not here is a way to do it using arrays and a dictionary. The advantage of this is that all of the cells are read in one go and then operated on in memory before writing back the results.
Sub SplitCells()
Dim i As Long
Dim temp() As Variant
Dim dict As Variant
' Create a dictionary
Set dict = CreateObject("scripting.dictionary")
' set temp array to values to loop through
With Sheet1
'Declare your range to loop through
temp = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
' Split the values in the array and add to dictionary
For i = LBound(temp) To UBound(temp)
dict.Add i, Split(temp(i, 1), " ")
Next i
' Print dictionary results
With Sheet1.Cells(1, 2)
For Each Key In dict.keys
.Range(.Offset(Key - 1, 0), .Offset(Key - 1, UBound(dict.Item(Key)))) = dict.Item(Key)
Next Key
End With
End Sub
Output:
Can anyone walk me through how to write a script to delete the entire row if a cell in column D = "" on sheet 3 in range D13:D40.
Also, how to prevent the user from accidentally running the script again once those cells in the range are already deleted and other cells are now on the D13:D40 range?
Solution: This is working for me:
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.ActiveSheet.Range("D13:D40")
With rng
' Loop through all cells of the range
' Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
' Since cell is empty, delete the whole row
.Item(i).EntireRow.Delete
End If
Next i
End With
End Sub
Explanation: Run a for loop through all cells in your Range in column D and delete the entire row if the cell value is empty. Important: When looping through rows and deleting some of them based on their content, you need to loop backwards, not forward. If you go forward and you delete a row, all subsequent rows get a different row number (-1). And if you have two empty cells next to each other, only the row of the first one will be deleted because the second one is moved one row up but the loop will continue at the next line.
No need for loops:
Sub SO()
Static alreadyRan As Integer
restart:
If Not CBool(alreadyRan) Then
With Sheets("Sheet3")
With .Range("D13:D40")
.AutoFilter 1, "="
With .SpecialCells(xlCellTypeVisible)
If .Areas.Count > 1 Then
.EntireRow.Delete
alreadyRan = alreadyRan + 1
End If
End With
End With
.AutoFilterMode = False
End With
Else
If MsgBox("procedure has already been run, do you wish to continue anyway?", vbYesNo) = vbYes Then
alreadyRan = 0
GoTo restart:
End If
End If
End Sub
Use AutoFilter to find blank cells, and then use SpecialCells to remove the results. Uses a Static variable to keep track of when the procedure has been run.
Here's my take on it. See the comments in the code for what happens along the way.
Sub deleterow()
' First declare the variables you are going to use in the sub
Dim i As Long, safety_net As Long
' Loop through the row-numbers you want to change.
For i = 13 To 40 Step 1
' While the value in the cell we are currently examining = "", we delete the row we are on
' To avoid an infinite loop, we add a "safety-net", to ensure that we never loop more than 100 times
While Worksheets("Sheet3").Range("D" & CStr(i)).Value = "" And safety_net < 100
' Delete the row of the current cell we are examining
Worksheets("Sheet3").Range("D" & CStr(i)).EntireRow.Delete
' Increase the loop-counter
safety_net = safety_net + 1
Wend
' Reset the loop-counter
safety_net = 0
' Move back to the top of the loop, incrementing i by the value specified in step. Default value is 1.
Next i
End Sub
To prevent a user from running the code by accident, I'd probably just add Option Private Module at the top of the module, and password-protect the VBA-project, but then again it's not that easy to run it by accident in the first place.
This code executes via a button on the sheet that, once run, removes the button from the worksheet so it cannot be run again.
Sub DeleteBlanks()
Dim rw As Integer, buttonID As String
buttonID = Application.Caller
For rw = 40 To 13 Step -1
If Range("D" & rw) = "" Then
Range("D" & rw).EntireRow.Delete
End If
Next rw
ActiveSheet.Buttons(buttonID).Delete
End Sub
You'll need to add a button to your spreadsheet and assign the macro to it.
There is no need for loops or filters to find the blank cells in the specified Range. The Range.SpecialCells property can be used to find any blank cells in the Range coupled with the Range.EntireRow property to delete these. To preserve the run state, the code adds a Comment to the first cell in the range. This will preserve the run state even if the Workbook is closed (assuming that it has been saved).
Sub DeleteEmpty()
Dim ws As Excel.Worksheet
Set ws = ActiveSheet ' change this as is appropriate
Dim sourceRange As Excel.Range
Set sourceRange = ws.Range("d13:d40")
Dim cmnt As Excel.Comment
Set cmnt = sourceRange.Cells(1, 1).Comment
If Not cmnt Is Nothing Then
If cmnt.Text = "Deleted" Then
If MsgBox("Do you wish to continue with delete?", vbYesNo, "Already deleted!") = vbNo Then
Exit Sub
End If
End If
End If
Dim deletedThese As Excel.Range
On Error Resume Next
' the next line will throw an error if no blanks cells found
' hence the 'Resume Next'
Set deletedThese = sourceRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not deletedThese Is Nothing Then
deletedThese.EntireRow.Delete
End If
' for preserving run state
If cmnt Is Nothing Then Set cmnt = sourceRange.Cells(1, 1).AddComment
cmnt.Text "Deleted"
cmnt.Visible = False
End Sub
I've recently had to write something similar to this. I'm not sure that the code below is terribly professional, as it involves storing a value in cell J1 (obviously this can be changed), but it will do the job you require. I hope this helps:
Sub ColD()
Dim irow As long
Dim strCol As String
Sheets("sheet2").Activate
If Cells(1, 10) = "" Then
lrun = " Yesterday."
Else: lrun = Cells(1, 10)
End If
MsgBox "This script was last run: " & lrun & " Are you sure you wish to continue?", vbYesNo
If vbYes Then
For irow = 40 To 13 step -1
strCol = Cells(irow, 4).Value
If strCol = "" Then
Cells(irow, 4).EntireRow.Delete
End If
Next
lrun = Now()
Cells(1, 10) = lrun
Else: Exit Sub
End If
End Sub
I am new to this. I am trying to find the lowest value in a cell with multiple values inside. For example,
48
44.50
41.00
37.50
I am trying to find 37.50. What should be the code for it?
Thanks
Based on your posted example:
Sub FindMin()
Dim s As String, CH As String
Dim wf As WorksheetFunction
Dim bry() As Double
Set wf = Application.WorksheetFunction
s = ActiveCell.Text
CH = Chr(10)
ary = Split(s, CH)
ReDim bry(LBound(ary) To UBound(ary))
For i = LBound(ary) To UBound(ary)
bry(i) = CDbl(ary(i))
Next i
MsgBox wf.Min(bry)
End Sub
This assumes that there is a hard return (ASCII-10) between the fields in the cell.
EDIT#1:
To make it into a function, remove the sub and replace with:
Public Function FindMin(r As Range) As Variant
Dim s As String, CH As String
Dim wf As WorksheetFunction
Dim bry() As Double
Set wf = Application.WorksheetFunction
s = r.Text
CH = Chr(10)
ary = Split(s, CH)
ReDim bry(LBound(ary) To UBound(ary))
For i = LBound(ary) To UBound(ary)
bry(i) = CDbl(ary(i))
Next i
FindMin = wf.Min(bry)
End Function
EDIT#2:
based on your comment, here is an example of input vs output:
Note that all the values are in a single cell and the values are separated by hard returns rather than spaces.
By code with same cell and a " " as delimiter to break
temp = Range("A1").Value
temp = Split(temp, " ")
Low = CInt(temp(0))
For i = 0 To UBound(temp) - 1
If CInt(temp(i)) < Low Then Low = CInt(temp(i))
Next
Range("a2").Value = Low
if they are in a range you can use a formula
=MIN(A1:A4)
This question is pretty close to one previously asked:
VBA/EXCEL: extract numbers from one cell that contained multiple values with comma
If you take the code from that answer and replace the comma with whatever is separating your values, you will be able to get access to them in VBA. Then you can write code to find the minimum.
You can make a macro to split the values for each cell you selected and then check for the highest value. And a quick check to make sure you are not parsing all the empty rows (when you selected a column).
The macro below will set the highest value in the next column.
Sub lowest()
Dim Values As Variant
Dim LowestValue As Double
Dim a As Range
Set a = Selection
For Each Row In a.Rows
For Each Cell In Row.Cells
LowestValue = -1
Values = Split(Cell.Value, Chr(10))
For Each Value In Values
If LowestValue = -1 Then
LowestValue = Value
ElseIf Value < LowestValue Then
LowestValue = Value
End If
Next
Cells(Cell.Row, Cell.Column + 1).Value = LowestValue
If IsEmpty(Cell.Value) Then GoTo EndLoop
Next Cell
Next Row
EndLoop:
End Sub
What I'm looking to do is comb through a column and pull all the unique identifiers out of that column and then paste the results in a table in a different worksheet. I found the code below and it is very close to what I need. However, I have two major problems with it that I cannot figure out. First the area that this macro searches is constant ie "A1:B50". I need this to be one column and be dynamic since more data and new unique identifiers will be added to this worksheet. Second I cannot figure out how to paste my results to a specific range on a different worksheet. For example if I wanted to take the results and paste them in "sheet2" starting in at "B5" and going to however long the list of unique identifiers is.
Sub ExtractUniqueEntries()
Const ProductSheetName = "Sheet1" ' change as appropriate
Const ProductRange = "B2:B"
Const ResultsCol = "E"
Dim productWS As Worksheet
Dim uniqueList() As String
Dim productsList As Range
Dim anyProduct
Dim LC As Integer
ReDim uniqueList(1 To 1)
Set productWS = Worksheets(ProductSheetName)
Set productsList = productWS.Range(ProductRange)
Application.ScreenUpdating = False
For Each anyProduct In productsList
If Not IsEmpty(anyProduct) Then
If Trim(anyProduct) <> "" Then
For LC = LBound(uniqueList) To UBound(uniqueList)
If Trim(anyProduct) = uniqueList(LC) Then
Exit For ' found match, exit
End If
Next
If LC > UBound(uniqueList) Then
'new item, add it
uniqueList(UBound(uniqueList)) = Trim(anyProduct)
'make room for another
ReDim Preserve uniqueList(1 To UBound(uniqueList) + 1)
End If
End If
End If
Next ' end anyProduct loop
If UBound(uniqueList) > 1 Then
'remove empty element
ReDim Preserve uniqueList(1 To UBound(uniqueList) - 1)
End If
'clear out any previous entries in results column
If productWS.Range(ResultsCol & Rows.Count).End(xlUp).Row > 1 Then
productWS.Range(ResultsCol & 2 & ":" & _
productWS.Range(ResultsCol & Rows.Count).Address).ClearContents
End If
'list the unique items found
For LC = LBound(uniqueList) To UBound(uniqueList)
productWS.Range(ResultsCol & Rows.Count).End(xlUp).Offset(1, 0) = _
uniqueList(LC)
Next
'housekeeping cleanup
Set productsList = Nothing
Set productWS = Nothing
End Sub
I think your solution is a bit more tricky than it needs to be. Collecting unique ids becomes almost trivial is you use a Dictionary instead of a list. The added benefit is that a dictionary will scale much better than a list as your data set becomes larger.
The code below should provide you with a good starting point to get you going. For convenience's sake I used the reference from your post. So output will be on sheet2 to starting in cell B5 going down and the input is assumed to be on sheet1 cell B2 going down.
If you have any questions, please let me know.
Option Explicit
Sub ExtractUniqueEntries()
'enable microsoft scripting runtime --> tools - references
Dim unique_ids As New Dictionary
Dim cursor As Range: Set cursor = ThisWorkbook.Sheets("Sheet1").Range("B2") 'change as Required
'collect the unique ids
'This assumes that:
'1. ids do not contain blank rows.
'2. ids are properly formatted. Should this not be the could you'll need to do some validating.
While Not IsEmpty(cursor)
unique_ids(cursor.Value) = ""
Set cursor = cursor.Offset(RowOffset:=1)
Wend
'output the ids to some target.
'assumes the output area is blank.
Dim target As Range: Set target = ThisWorkbook.Sheets("Sheet2").Range("B5")
Dim id_ As Variant
For Each id_ In unique_ids
target = id_
Set target = target.Offset(RowOffset:=1)
Next id_
End Sub
A small modification will do it; the key is to define the ProductRange.
Sub ExtractUniqueEntries()
Const ProductSheetName = "Sheet1" ' change as appropriate
Dim ProductRange
ProductRange = "B2:B" & Range("B" & Cells.Rows.Count).End(xlUp).Row
Const ResultsCol = "E"
Dim productWS As Worksheet
Dim uniqueList() As String
Dim productsList As Range
Dim anyProduct
Dim LC As Integer
ReDim uniqueList(1 To 1)
Set productWS = Worksheets(ProductSheetName)
Set productsList = productWS.Range(ProductRange)
Application.ScreenUpdating = False
For Each anyProduct In productsList
If Not IsEmpty(anyProduct) Then
If Trim(anyProduct) <> "" Then
For LC = LBound(uniqueList) To UBound(uniqueList)
If Trim(anyProduct) = uniqueList(LC) Then
Exit For ' found match, exit
End If
Next
If LC > UBound(uniqueList) Then
'new item, add it
uniqueList(UBound(uniqueList)) = Trim(anyProduct)
'make room for another
ReDim Preserve uniqueList(1 To UBound(uniqueList) + 1)
End If
End If
End If
Next ' end anyProduct loop
If UBound(uniqueList) > 1 Then
'remove empty element
ReDim Preserve uniqueList(1 To UBound(uniqueList) - 1)
End If
'clear out any previous entries in results column
If productWS.Range(ResultsCol & Rows.Count).End(xlUp).Row > 1 Then
productWS.Range(ResultsCol & 2 & ":" & _
productWS.Range(ResultsCol & Rows.Count).Address).ClearContents
End If
'list the unique items found
For LC = LBound(uniqueList) To UBound(uniqueList)
productWS.Range(ResultsCol & Rows.Count).End(xlUp).Offset(1, 0) = _
uniqueList(LC)
Next
'housekeeping cleanup
Set productsList = Nothing
Set productWS = Nothing
End Sub
I am using Microsoft Excel to keep track of tasks. I use a different "sheet" for each job. The structure is with regards to columns and data. I have been trying to create a VBA script that would accomplish the following:
Search sheets 1 - X for a value of "Open" or "Past Due" in a row
Copy all rows with those values into a single sheet (such as a ledger) starting at row 3 (so I can add the headers of the template)
Add a column A with the sheet name so that I know what job it came from.
Run this to my hearts obsessive compulsive behavior pleasure to update with new items
I have been using the following posts to help guide me:
Search a specific word and copy line to another Sheet <- which was helpful but not quite right...
Copying rows to another worksheet based on a search on a grid of tags <-- also helpful, but limited to the activesheet and not looping correctly with my modifications...
The last two evenings have been fun, but I feel like I may be making this harder than necessary.
I was able to create a VBA script (edited from another post here) to sweep through all the worksheets, but it was designed to copy all data in a set of columns. I tested that and it worked. I then merged the code base I was using to identify "Open" or "Past Due" in column C (that worked for only the activesheet) into the code. I marked up my edits to share here. At this point it is not functioning, and I have walked myself dizzy. Any tips on where I fubar-ed the code would be appreciated. My code base I working from is:
Sub SweepSheetsCopyAll()
Application.ScreenUpdating = False
'following variables for worksheet loop
Dim W As Worksheet, r As Single, i As Single
'added code below for finding the fixed values on the sheet
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim h As Long 'h replaced i variable from other code
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop all rows in a sheet to find last line
For r = 4 To lastLine 'formerly was "To W.Cells(Rows.Count, 1).End(xlUp).Row"
'insert below row match search copy function
For Each cell In Range("B1:L1").Offset(r - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
' original code Rows(r).Copy Destination:=Sheets(2).Rows(j)
Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
j = j + 1
End If
toCopy = False
'Next
'end above row match search function
'below original code that copied everything from whole worksheet
' If W.Cells(r, 1) > 0 Then
' Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
' ThisWorkbook.Worksheets("Summary").Cells(i, 1)
' i = i + 1
' End If
Next r
End If
Next W
End Sub
The working code base to sweep through all the sheets was:
Sub GetParts()
Application.ScreenUpdating = False
Dim W As Worksheet, r As Single, i As Single
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
If W.Cells(r, 1) > 0 Then
Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
i = i + 1
End If
Next r
End If
Next W
End Sub
And the copy the matched data from the Activesheet is as follows:
Sub customcopy()
Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop through all sheets here
'below code does nice job finding all findWhat and copying over to spreadsheet2
j = 1
For i = 1 To lastLine
For Each cell In Range("B1:L1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
toCopy = False
Next
i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")
Application.ScreenUpdating = True
End Sub
You should look into this Vba macro to copy row from table if value in table meets condition
In your case, you would need to create a loop, using this advanced filter to copy the data to your target range or array.
If you need further advice, please post your code, and where you are stuck with it.