How can I make this code find all occurrences of the cell value? Right now it iterates and then pastes the same row (first time it appears), it's not moving past that row to find the remaining rows that match the row. Sheet A has the part appear more than once. Any help would be appreciated! Thanks!
Sub Update_Data()
Dim d As Worksheet: Set d = ThisWorkbook.Worksheets("Sheet D")
Dim a As Worksheet: Set a = ThisWorkbook.Worksheets("Sheet A")
' **IMPORTANT** header row locations
Dim d_headerRow As Integer: d_headerRow = 1
Dim a_headerRow As Integer: a_headerRow = 1
Dim i As Long, j As Long, k As Integer, part As String
Dim d_lastRow As Long: d_lastRow = d.Cells(d.Rows.Count, 1).End(xlUp).Row
Dim a_lastRow As Long: a_lastRow = a.Cells(a.Rows.Count, 1).End(xlUp).Row
Dim a_lastCol As Integer: a_lastCol = a.Cells(a_headerRow, a.Columns.Count).End(xlToLeft).Column
For i = d_headerRow + 1 To d_lastRow
part = d.Cells(i, 1).Value
For j = a_headerRow + 1 To a_lastRow
If part = a.Cells(j, 1).Value Then
a.Range(a.Cells(j, 1), a.Cells(j, a_lastCol)).Copy Destination:=d.Range(d.Cells(i, 11), d.Cells(i, 11))
Exit For
End If
Next j
Next i
End Sub
Related
Screenshot#1
So i have to replace positive & negative numbers in column "A", from sheet "1" to sheet second[positive] and third sheet[negative].
Here is what i tried:
Sub Verify()
Dim row As Long
For row = 1 To 20
If ActiveSheet.Cells(row,1) <> "" Then
If ActiveSheet.Cells(row,1) > 0 Then
ActiveSheet.Cells(row,2) = ActiveSheet.Cells(row,1)
End If
End If
Next
End Sub
Here is what that program do:
Screenshot#2
So as we see i am getting positive values in column "B" sheet 1.
Your code is not currently working because you are only using ActiveSheet, rather than placing data on other worksheets as required. Below is some VBA code that loops column A in your original sheet, and outputs the data to column A in two different sheets as required:
Sub sSplitPositiveNegative()
Dim wsOriginal As Worksheet
Dim wsPositive As Worksheet
Dim wsNegative As Worksheet
Dim lngLastRow As Long
Dim lngPositiveRow As Long
Dim lngNegativeRow As Long
Dim lngLoop1 As Long
Set wsOriginal = ThisWorkbook.Worksheets("Original")
Set wsPositive = ThisWorkbook.Worksheets("Positive")
Set wsNegative = ThisWorkbook.Worksheets("Negative")
lngLastRow = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row
lngNegativeRow = 2
lngPositiveRow = 2
For lngLoop1 = 1 To lngLastRow
If wsOriginal.Cells(lngLoop1, 1).Value > 0 Then
wsPositive.Cells(lngPositiveRow, 1) = wsOriginal.Cells(lngLoop1, 1)
lngPositiveRow = lngPositiveRow + 1
Else
wsNegative.Cells(lngNegativeRow, 1) = wsOriginal.Cells(lngLoop1, 1)
lngNegativeRow = lngNegativeRow + 1
End If
Next lngLoop1
Set wsPositive = Nothing
Set wsNegative = Nothing
Set wsOriginal = Nothing
End Sub
You will need to change the names of the worksheets referenced in the code to match those in your workbook.
Regards
Made the code a little reusable for you. Feel free to change sheet names or the last_row variable. The last_pos_val and last_neg_val are used so you won't have empty rows on the second and third sheet. You didn't specify what to do with zero, so it's currently added to the negative sheet.
Sub Verify()
Dim row As Long, last_row As Long, last_pos_val As Long, last_neg_val As Long
Dim ws_source As Worksheet, ws_pos As Worksheet, ws_neg As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws_source = wb.Sheets("Sheet1")
Set ws_pos = wb.Sheets("Sheet2")
Set ws_neg = wb.Sheets("Sheet3")
last_pos_val = 1
last_neg_val = 1
last_row = 20
For row = 1 To last_row
If ws_source.Cells(row,1) <> "" Then
If ws_source.Cells(row,1) > 0 Then
ws_pos.Cells(last_pos_val,1) = ws_source.Cells(row,1)
last_pos_val = last_pos_val + 1
Else
ws_neg.Cells(last_neg_val,1) = ws_source.Cells(row,1)
last_neg_val = last_neg_val + 1
End If
End If
Next
End Sub
Split Positive & Negative
Adjust the values in the constants section.
Both subs are needed. The first sub calls the second one.
The Code
Option Explicit
Sub SplitPN()
Const Source As String = "Sheet1"
Const Positive As String = "Sheet2"
Const Negative As String = "Sheet3"
Const FirstRow As Long = 1
Const SourceColumn As Long = 1
Const PositiveFirstCell As String = "A1"
Const NegativeFirstCell As String = "A1"
Dim rngSource As Range
Dim rngPositive As Range
Dim rngNegative As Range
With ThisWorkbook
With .Worksheets(Source)
Set rngSource = .Columns(SourceColumn).Find(What:="*", _
LookIn:=xlFormulas, SearchDirection:=xlPrevious)
If rngSource Is Nothing Then Exit Sub
If rngSource.Row < FirstRow Then Exit Sub
Set rngSource = .Range(.Cells(FirstRow, SourceColumn), rngSource)
End With
Set rngPositive = .Worksheets(Positive).Range(PositiveFirstCell)
Set rngNegative = .Worksheets(Negative).Range(NegativeFirstCell)
End With
SplitPosNeg rngSource, rngPositive, rngNegative
End Sub
Sub SplitPosNeg(SourceRange As Range, PositiveFirstCell As Range, _
NegativeFirstCell As Range)
Dim Source, Positive, Negative
Dim UB As Long, i As Long
Source = SourceRange
UB = UBound(Source)
ReDim Positive(1 To UB, 1 To 1)
ReDim Negative(1 To UB, 1 To 1)
For i = 1 To UBound(Source)
Select Case Source(i, 1)
Case Is > 0: Positive(i, 1) = Source(i, 1)
Case Is < 0: Negative(i, 1) = Source(i, 1)
End Select
Next
PositiveFirstCell.Resize(UB) = Positive
NegativeFirstCell.Resize(UB) = Negative
End Sub
I want to match rows from two different sheets and highlight only in the first column of the unmatched row or better still copy the unmatched rows into a new sheet. The code should compare the rows of the two Sheets and color the new rows in the second sheet. Sheet2 (say Jan 2020) contains more rows than Sheet1 (Dec 2019) as its the recently updated sheet and they both contain rows of over 22k with both having unique ID as the first column.
My below code tries to highlight all the unmatching cells and takes longer time to finish. What I wish is for the code to just color the unmatched in column A (the vb.Red) only(since its the unique ID) while ignoring the rest of the column/cells (vb.Yellow) and or if possible copy the highlighted rows into a new sheet.
Sub RunCompare()
Call compareSheets("Sheet1", "Sheet2") 'compareSheets("2019-01 Database", "2019-02 Database")
End Sub
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim c As Integer, j As Integer, i As Integer, mydiffs As Integer, cnt1 As Integer, cnt2 As Integer
Dim noexist As Integer
cnt2 = Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row
cnt1 = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For i = 1 To cnt2
For j = 1 To cnt1
If ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, 1).Value Then
For c = 2 To 22
If Not ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, c).Value Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
Exit For
End If
If j = cnt1 Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Interior.Color = vbRed
End If
Next
Next
'Display a message box to demonstrate the differences and if there is a new entry on the second sheet
'MsgBox mydiffs & ":differences found, " & noexist & ":no exist", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
End Sub
Let's simplify the task and do it step by step.
This is how the input in the two sheets can look like:
Then, we may consider reading these and saving them to an array:
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Looping between the data in the two arrays is quite fast in vba. The writing to the third worksheet is done only once the two values from the two arrays match:
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
This is the result in the third worksheet, all matching values are in a single row:
This is how the whole code looks like:
Sub CompareTwoRanges()
Dim rangeA As Range
Dim rangeB As Range
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
End Sub
Note - there will be another performance bonus, if the results are written to an array and then written from the array to the worksheet. Thus the writing would happen only once. This is the change, that needs to be implemented in the code, after the array declarations:
Dim myValA As Variant
Dim myValB As Variant
Dim resultArray() As Variant
ReDim Preserve resultArray(2 ^ 20)
Dim i As Long: i = 0
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
resultArray(i) = myValA
i = i + 1
End If
Next
Next
ReDim Preserve resultArray(i)
ThisWorkbook.Worksheets(3).Cells(1, 1).Resize(UBound(resultArray)) = Application.Transpose(resultArray)
when you get cell value, it spends time.
so, you can target Range transfer 2d Variant
Dim endRow AS Long
Dim olderRange AS Range
Dim olderVariant AS Variant
endRow = olderSheet.cells(rows.count,1).end(xlup).row
Set olderRange = olderSheet.Range(olderSheet.Cells(startRow, startCol), olderSheet.Cells(endRow, endCol))
'Transfer
olderVariant = olderRange
For currentRow = 1 to UBound(olderVariant, 1)
'Loop
'if you want change real Cell value Or interior
'add row Or Col weight
if olderVariant(currentRow, currentCol) = newerVariant(currentRow, currentCol) THen
newerSheet.Cells(currentRow+10,currentCol+10).interior.colorIndex = 3
End if
Next currentRow
In case anyone has the same kind of problem, I have found an easier way to do it. Providing your sheet2 is the comparison sheet:
Dim Ary1 As Variant, Ary2 As Variant
Dim r As Long
Ary1 = Sheets("Sheet1").UsedRange.Value2
Ary2 = Sheets("Sheet2").UsedRange.Value2
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary1)
.Item(Ary1(r, 1)) = Empty
Next r
For r = 1 To UBound(Ary2)
If Not .Exists(Ary2(r, 1)) Then Sheets("Sheet2").Cells(r, 1).Interior.Color = vbRed
Next r
End With
I have this sample table.
What I am trying to do is to get all the cell values in all colored cells and transpose them to another worksheet.
I have trouble with the code below to add and set those ranges together so that I can transpose all of them in a ROW in the other worksheet. I have started with the code below
Sub AddRanges()
Dim inRange As Range, inRangeValues() As Variant, outRangeValues() As Variant
Dim finalRow As Long
Dim inRange As Range
Set inRange = Sheet1.Range("A1:A6", "C1:C6", C10:C14) 'I think i got this wrong; Error Type Mismatch
inRangeValues() = inRange.Value 'generate 2d array
outRangeValues = Application.Transpose(inRangeValues)
With Sheet2
finalRow = .Cells(Rows.Count, 1).End(xlUp).Row 'find last row
If inRange.Columns.Count > 1 Then '2d array for output
.Cells(finalRow + 1, 1).Resize(UBound(outRangeValues, 1), UBound(outRangeValues, 2)) = outRangeValues 'Resize according to output array dimensions
Else '1D array for output
.Cells(finalRow + 1, 1).Resize(1, UBound(outRangeValues, 1)) = outRangeValues
End If
End With
End sub
In this example, what is the best approach to combine these ranges so I can transpose them as a ROW? Thanks.
Your code has major problems due to:
Double declaration of inRange
Wrong syntax for Set inRange the entire address needs to be enclosed in a single pair of quotes
Try Set inRange = Range("a1:a6, c1:c6, c10:c14")
Wrong method of reading into an array
When you have a range that consists of multiple areas, you have to convert each area separately.
Then you can create a 1-D array from this depending on the order you wish to have these elements, and write it wherever you want.
For example:
Option Explicit
Sub test()
Dim inRange As Range, inRangeValues As Variant, outRangeValues As Variant
Dim finalRow As Long
Dim I As Long, J As Long, V As Variant, L As Long
Dim lCols As Long
Set inRange = Range("a1:a6, c1:c6, c10:c14")
ReDim inRangeValues(1 To inRange.Areas.Count)
For I = 1 To inRange.Areas.Count
inRangeValues(I) = inRange.Areas(I)
Next I
'how many columns?
lCols = 0
For I = 1 To UBound(inRangeValues, 1)
lCols = lCols + UBound(inRangeValues(I), 1)
Next I
ReDim outRangeValues(1 To lCols)
L = 0
For I = 1 To UBound(inRangeValues, 1)
For J = 1 To UBound(inRangeValues(I), 1)
L = L + 1
outRangeValues(L) = inRangeValues(I)(J, 1)
Next J
Next I
Stop
' enter some code to write the results where you want
' below is just throwaway for proof of concept
Range("f20").Resize(columnsize:=UBound(outRangeValues)).Value = outRangeValues
End Sub
Given your input, the above code would create output like:
You are correct that your code is wrong where you highlight. Try a union. From there, it should be pretty basic to just loop through your range and put them wherever you want in the Sheet2 spreadsheet. See if the below does what you need.
Sub AddRanges()
Dim inRange As Range, acell As Range, aCounter As Long
Const startAddress As String = "A1"
Set inRange = Union(Sheet1.Range("A1:A6"), Sheet1.Range("C1:C6"), Sheet1.Range("C10:C14"))
For Each acell In inRange.Cells
If Not IsEmpty(acell) Then
finalRow = sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1 'find last row
sheet2.Cells(finalRow, 1).Value = acell.Value
End If
Next acell
End Sub
Check it out.
Sub RngAreaTransps()
Dim RangeArea As Range, LstRw As Long
Dim sh As Worksheet, ws As Worksheet
Dim col As Long, InRange As Range
Set sh = Sheets(1)
Set ws = Sheets(2)
LstRw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
With sh
Set InRange = .Range("A1:A6, C1:C6, C10:C14")
For Each RangeArea In InRange.Areas
With ws
col = .Cells(LstRw, .Columns.Count).End(xlToLeft).Column
If col <> 1 Then col = col + 1
RangeArea.SpecialCells(xlCellTypeConstants).Copy
.Cells(LstRw, col).PasteSpecial Transpose:=True
End With
Next RangeArea
End With
Application.CutCopyMode = False
End Sub
I wanted to copy data that fulfil a few criteria from one sheet to another using VBA.
My goal:
Copy Cell in column E, F and G in Sheet FP to column R, S and T in Sheet MUOR if it meets my conditions.
My conditions:
(1) Cell in Column D & Cell in Column P (in Sheet MUOR) must meet the condition in Column I of Sheet FP.
(2) If Cell in Column D is empty, skip to next Cell in Column D.
(3) Column R, S or T must be empty before pasting it. If not empty, move to the next cell that meets the condition. (Do not replace or duplicate the data)
Other information: Max Batch No (Column D) per day is 3;
Issue Facing:
My current VBA code doesn't recognise my conditions. It totally ignored my Day 1 data, and it duplicated all the Day 2 data.
Please refer to the attached images.
Sheet MUOR
Sheet FP
My expected Result
Sample Data here
My current code as below:
Sub LinkData()
Dim y As Long
Dim x As Long
Dim z As Long
Dim lr As Long
Dim arr As Variant
Dim FP As Worksheet
Dim MUOR As Worksheet
Set FP = ThisWorkbook.Sheets("FP")
Set MUOR = ThisWorkbook.Sheets("MUOR")
With FP
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = .Range("A1:I" & lr).Value
End With
With MUOR
For y = 11 To 363
For z = y - 1 To y + 8
For x = LBound(arr) To UBound(arr)
If Cells(11 + y, 4) <> "" And Cells(11 + y, 4) & Cells(10 + z, 16) = arr(x, 9) And IsEmpty(Cells(10 + z, 18)) Then
.Cells(10 + z, 18) = arr(x, 5)
.Cells(10 + z, 19) = arr(x, 8)
.Cells(10 + z, 20) = arr(x, 7)
Else
End If
Next x
Next z
Next y
End With
End Sub
Any VBA expert please help me.
Much appreciated!
I think code below should give expected output, but not totally sure, since the workbook uploaded/shared seems to differ from the screenshots in the question.
Option Explicit
Private Sub LinkData()
Dim arrayFromFPSheet() As Variant
arrayFromFPSheet = GetSourceArray()
Dim MUOR As Worksheet
Set MUOR = ThisWorkbook.Worksheets("MUOR")
Dim rangesToLoopThrough As Range
Set rangesToLoopThrough = GetDestinationAreas(MUOR)
With MUOR
Dim area As Range
For Each area In rangesToLoopThrough.Areas
Debug.Assert area.Rows.CountLarge > 1 And area.Rows.CountLarge < 20
Dim areaFirstRowIndex As Long
areaFirstRowIndex = area.Rows(1).Row
Dim areaLastRowIndex As Long
areaLastRowIndex = area.Rows(area.Rows.Count).Row
Dim readRowIndex As Long
For readRowIndex = areaFirstRowIndex To areaLastRowIndex
If Not IsCellEmpty(.Cells(readRowIndex, "D")) Then
Dim batchNumber As String
batchNumber = CStr(.Cells(readRowIndex, "D"))
Dim writeRowIndex As Long
For writeRowIndex = areaFirstRowIndex To areaLastRowIndex
If IsCellEmpty(.Cells(writeRowIndex, "R")) And IsCellEmpty(.Cells(writeRowIndex, "S")) And IsCellEmpty(.Cells(writeRowIndex, "T")) Then
Dim Grade As String
Grade = CStr(.Cells(writeRowIndex, "P"))
Dim batchNumberAndGrade As String
batchNumberAndGrade = batchNumber & Grade
Dim n As Variant
n = Application.CountIfs(.Range("P" & areaFirstRowIndex, "P" & writeRowIndex), Grade, .Range("R" & areaFirstRowIndex, "R" & writeRowIndex), batchNumber) + 1
Debug.Assert IsNumeric(n)
Dim sourceRowIndex As Long
sourceRowIndex = GetRowIndexOfNthMatch(n, arrayFromFPSheet, batchNumberAndGrade, 9)
If sourceRowIndex > 0 Then
.Cells(writeRowIndex, "R") = arrayFromFPSheet(sourceRowIndex, 5)
.Cells(writeRowIndex, "S") = arrayFromFPSheet(sourceRowIndex, 8)
.Cells(writeRowIndex, "T") = arrayFromFPSheet(sourceRowIndex, 7)
End If
End If
Next writeRowIndex
End If
Next readRowIndex
Next area
End With
End Sub
Private Function GetDestinationAreas(ByVal someSheet As Worksheet) As Range
' Crudely clusters/groups destination sheet into areas (which
' should be date-specific, although this function will not check/verify
' output).
Const START_ROW_INDEX As Long = 10
Dim outputRange As Range
Set outputRange = someSheet.Range("C" & START_ROW_INDEX, "C" & someSheet.Rows.Count)
On Error Resume Next
Set outputRange = outputRange.SpecialCells(xlCellTypeConstants) ' Will raise error if no constants found.
On Error GoTo 0
Debug.Assert Not (outputRange Is Nothing)
Set GetDestinationAreas = outputRange
End Function
Private Function GetSourceArray() As Variant
With ThisWorkbook.Worksheets("FP")
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim outputArray() As Variant
outputArray = .Range("A1:I" & lastRow).Value
End With
GetSourceArray = outputArray
End Function
Private Function IsCellEmpty(ByVal someCell As Range) As Boolean
' https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/isempty-function
' "IsEmpty only returns meaningful information for variants."
' So using below function instead.
IsCellEmpty = Len(CStr(someCell.Value)) = 0
End Function
Private Function GetRowIndexOfNthMatch(ByVal n As Long, ByRef someArray() As Variant, ByVal someText As String, ByVal targetColumn As Long) As Long
' Returns a 1-based row index of the nth occurrence of text value
' in target column of array or 0 if unsuccessful.
Debug.Assert n > 0
Dim rowIndex As Long
For rowIndex = LBound(someArray, 1) To UBound(someArray, 1)
If someArray(rowIndex, targetColumn) = someText Then
Dim matchCount As Long
matchCount = matchCount + 1
If matchCount = n Then
GetRowIndexOfNthMatch = rowIndex
Exit Function
End If
End If
Next rowIndex
End Function
Thanks for all the information you provided in the question. It makes it easier to answer.
All-
I'm very new to VBA and I really need help. I have a worksheet called Sheet 1 that looks like this (This is where the data will be copied from)
and another sheet (Sheet2) that looks like this (this is where the data will be copied to). Notice that the order is not the same as above
When a user types in a place such as "Paris" I want it to copy all corresponding values with "Paris" and it's associated rows. So the end result should look like this
Here is the code I have so far. Right now I can pull all the corresponding values based on the Users input, but I cannot for the life of me figure out how to get the associated rows. Please help! Any input will be highly appreciated.
Dim x As String
Dim K As Long
Dim ct As Variant
Dim r As Range
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
x = Application.InputBox("Please Enter Place")
w1.Activate
K = 3
For Each r In Intersect(Range("C3:C3" & a), ActiveSheet.UsedRange)
ct = r.Value
If InStr(ct, x) > 0 And ct <> "" Then
r.Copy w2.Cells(K, 1)
K = K + 1
w2.Activate
End If
Next r
End Sub
Assign the entire range to an array for quicker looping, then once the array finds a match to your inputstring, rewrite the values to your 2nd sheet.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, wsArr()
set ws1 = thisworkbook.worksheets("Sheet1")
set ws2 = thisworkbook.worksheets("Sheet2")
With ws1
wsArr = .Range(.Cells(3, 1), .Cells(LastRow(ws1), 4)).Value
End With
Dim findStr As String
findStr = InputBox("Please Enter Place")
Dim i As Long, r as long
Application.ScreenUpdating = False
With ws2
.Range("A3:D3").Value = array("Place", "Name", "Thing", "Animal")
For i = LBound(wsArr) To UBound(wsArr)
If wsArr(i, 3) = findStr Then
r = LastRow(ws2) + 1
.Cells(r, 1) = wsArr(i, 3)
.Cells(r, 2) = wsArr(i, 1)
.Cells(r, 3) = wsArr(i, 2)
.Cells(r, 4) = wsArr(i, 4)
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
With ws
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
For even better performance, consider doing a COUNTIF() to get the count of the number of findStr occurances in your range - that way you can use this value to ReDim a new array in order to write the matches there, then write the array to Sheet2 all at once.