Function to check for specific value in a range of cells and output 'TRUE' in a helper column - excel

I'm trying to check a range of cells for the value "X" and when the column name where the "X" was found is among an array I have previously specified, I want to have a helper column that would say TRUE otherwise say FALSE.
To illustrate, here's a sample table:
In my sample, I have this array that contains 3 values ( Math, English and History). If there is an X in any of the rows whose header name is in the array, I want the helper column to say TRUE otherwise FALSE. It doesn't have to be all of the values in the array, it can be at least only one.
Here is my code (my original file has more columns than my sample, so my code is liek this)
Sub add_helper()
' Adding helper column
Dim checking As Variant
checking = check_issue() -- this is another function, basically checking will contain the values I want to check in this case Math, English and History, i have confirmed this gets it successfully
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "I").End(xlUp).row
Set rowRange = wks.Range("I2:AD" & LastRow)
Set colRange = wks.Range("I1:AD1")
'Loop through each row
For Each rrow In rowRange
Do
For Each cell In colRange
'Do something to each cell
If InStr(checking, cell.value) > 0 Then
If Cells(rrow.row, rrow.Column).value <> "" Then
wks.Range("AI" & rrow.row).value = "TRUE"
Exit For
Else
wks.Range("AI" & rrow.row).value = "FALSE"
End If
End If
Next cell
Loop Until wks.Range("AI" & rrow.row).value <> "TRUE"
Next rrow
End Sub
My code results to just having an input of true whenever there is an X without actually checking if the header column is in my array.

Did you try normal formulas in Excel? You could create a table (a ListObject) with the courses as your array values and the combine SUMPRODUCT with COUNTIF to output True/False in your helper column. Easy to update and adapt:
Notice the table at most right named T_COURSES. The formula in helper column is:
=SUMPRODUCT(--(COUNTIF(T_COURSES,$B$1:$E$1)>0)*--(B2:E2="x"))>0
It works perfectly and it autoupdates changing values:

Match Headers of Matches Against Values in Array
Option Explicit
Sub AddHelper()
Dim checking As Variant: checking = check_issue()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim hrg As Range: Set hrg = ws.Range("I1:AD1") ' Header Range
Dim drg As Range ' Data Range
Set drg = ws.Range("I2:AD" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row)
Dim crg As Range: Set crg = drg.EntireRow.Columns("AI") ' (Helper) Column Range
crg.Value = False
Dim rrg As Range, rCell As Range, r As Long, c As Long, IsFound As Boolean
For Each rrg In drg.Rows
r = r + 1 ' for the (helper) column range
c = 0 ' for the header range
For Each rCell In rrg.Cells
c = c + 1
If StrComp(CStr(rCell.Value), "x", vbTextCompare) = 0 Then
If IsNumeric(Application.Match(CStr(hrg.Cells(c)), checking, 0)) _
Then IsFound = True: Exit For
End If
Next rCell
If IsFound Then crg.Cells(r).Value = True: IsFound = False
Next rrg
End Sub

Related

Excel VBA - For Loop IS taking far far too long to execute

First question ever here, I am the newbiest newbie..
So.. what I am trying to get is:
to find if in sheet1 and sheet2 there are cells with the same value on column E from sheet1 and column F from sheet2. if there are, then copy the value from sheet2 column A row x to sheet2 column P row y.
rows x and y are where the identical values are on each sheet.
this is my code:
Sub ccopiazanrfact()
Dim camion As Worksheet
Dim facturi As Worksheet
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
Dim nrcomanda As String
Dim nrfactura As String
For a = 2 To facturi.Range("F" & Rows.Count).End(xlUp).Row
nrcomanda = facturi.Range("F" & a).Value
For b = 4 To camion.Range("E" & Rows.Count).End(xlUp).Row
If camion.Range("E" & b).Value = facturi.Range("F" & a).Value Then
camion.Range("P" & b) = facturi.Range("A" & a).Value
Exit For
End If
Next b
Next a
End Sub
I would recommend using arrays to achieve what you want. Nested looping over ranges can make it very slow. Is this what you are trying? (UNTESTED). As I have not tested it, I would recommend making a backup of your data before you test this code.
I have commented the code. But if you still have a question or find an error/bug in the below code then simply ask.
Option Explicit
Sub ccopiazanrfact()
Dim Camion As Worksheet
Dim Facturi As Worksheet
Set Camion = ThisWorkbook.Sheets("B816RUS")
Set Facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
'~~> Declare 2 arrays
Dim ArCamion As Variant
Dim ArFacturi As Variant
Dim LRow As Long
'~~> Find last row in Col E of Sheets("B816RUS")
LRow = Camion.Range("E" & Camion.Rows.Count).End(xlUp).Row
'~~> Store Values from E4:P last row in the array. We have taken E:P
'~~> because we are replacing the value in P if match found
ArCamion = Camion.Range("E4:P" & LRow).Value
'~~> Find last row in Col E of Sheets("EVIDENTA FACTURI")
LRow = ArFacturi.Range("F" & ArFacturi.Rows.Count).End(xlUp).Row
'~~> Store Values from A2:F last row in the array. We have taken A:F
'~~> because we are replacing the value in P with A
ArFacturi = Facturi.Range("A2:F" & LRow).Value
Dim i As Long, j As Long
For i = 2 To UBound(ArFacturi)
For j = 4 To UBound(ArCamion)
'~~> Checking if camion.Range("E" & j) = facturi.Range("F" & i)
If ArCamion(j, 1) = ArFacturi(i, 6) Then
'~~> Replacing camion.Range("P" & j) with facturi.Range("A" & i)
ArCamion(j, 12) = ArFacturi(i, 1)
Exit For
End If
Next j
Next i
'~~> Write the array back to the worksheet in one go
Camion.Range("E4:P" & LRow).Resize(UBound(ArCamion), 12).Value = ArCamion
End Sub
in the end, I came up with this and works instantly, get’s all the data filled within a blink of an eye. When I tried it first time I thought i forgot to clear the data before running the code:
Sub FindMatchingValues()
'Declare variables for the worksheets
Dim ws1 As Worksheet
Dim ws2 As Worksheet
'Set the variables to refer to the worksheets
Set ws1 = Worksheets("B816RUS")
Set ws2 = Worksheets("EVIDENTA FACTURI")
'Declare variables for the ranges to compare
Dim rng1 As Range
Dim rng2 As Range
'Set the ranges to the columns to compare
Set rng1 = ws1.Range("E1", ws1.Range("E" & Rows.Count).End(xlUp))
Set rng2 = ws2.Range("F1", ws2.Range("F" & Rows.Count).End(xlUp))
'Loop through each cell in the first range
For Each cell1 In rng1
'Use the Match function to find the matching value in the second range
Dim match As Variant
match = Application.match(cell1.Value, rng2, 0)
'If a match was found, copy the value from column A in the second worksheet to column P in the first worksheet
If Not IsError(match) Then
ws1.Range("P" & cell1.Row).Value = ws2.Range("A" & match).Value
End If
Next cell1
End Sub
Please, test the next code. It should be very fast, using arrays and Find function:
Sub ccopiazaNrfact()
Dim camion As Worksheet, facturi As Worksheet, cellMatch As Range, rngE As Range
Set camion = ThisWorkbook.Sheets("B816RUS")
Set facturi = ThisWorkbook.Sheets("EVIDENTA FACTURI")
Set rngE = camion.Range("E4:E" & camion.Range("E" & camion.rows.count).End(xlUp).row)
Dim a As Long, arrFact, arrP, nrComanda As String
arrP = camion.Range("P1:P" & camion.Range("E" & rows.count).End(xlUp).row).Value
arrFact = facturi.Range("A2:F" & facturi.Range("F" & rows.count).End(xlUp).row).Value
Debug.Print UBound(arrP): Stop
For a = 1 To UBound(arrFact)
nrComanda = arrFact(a, 6)
Set cellMatch = rngE.Find(What:=nrComanda, After:=rngE.cells(1, 1), LookIn:=xlValues, lookAt:=xlWhole)
If Not cellMatch Is Nothing Then
arrP(cellMatch.row, 1) = arrFact(a, 1)
End If
Next a
camion.Range("P1").Resize(UBound(arrP), 1).Value = arrP
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it...
A VBA Lookup: Using Arrays and a Dictionary
Option Explicit
Sub CopiazaNrFact()
Dim wb As Workbook: Set wb = ThisWorkbook
' Write the values from the Source Compare and Value ranges to arrays.
' f - Facturi (Source), c - Compare, v - Value
Dim frg As Range, fcData() As Variant, fvData() As Variant, frCont As Long
With wb.Sheets("EVIDENTA FACTURI")
' Compare
Set frg = .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))
frCont = frg.Rows.Count
fcData = frg.Value ' write to array
' Value
Set frg = frg.EntireRow.Columns("A")
fvData = frg.Value ' write to array
End With
' Write the unique values from the Source Compare array to the 'keys',
' and their associated values from the Source Values array to the 'items'
' of a dictionary.
Dim fDict As Object: Set fDict = CreateObject("Scripting.Dictionary")
fDict.CompareMode = vbTextCompare
Dim fr As Long, NrFacturi As String
For fr = 1 To frCont
NrFacturi = CStr(fcData(fr, 1))
If Len(NrFacturi) > 0 Then ' exclude blanks
fDict(NrFacturi) = fvData(fr, 1)
End If
Next fr
' Write the values from the Destination Compare range to an array
' and define the resulting same-sized Destination Value array.
' c - Camion (Destination), c - Compare, v - Value
Dim crg As Range, ccData() As Variant, cvData() As Variant, crCont As Long
With wb.Sheets("B816RUS")
' Compare
Set crg = .Range("E4", .Cells(.Rows.Count, "E").End(xlUp))
crCont = crg.Rows.Count
ccData = crg.Value ' write to array
' Value
Set crg = crg.EntireRow.Columns("P")
ReDim cvData(1 To crCont, 1 To 1) ' define
End With
' For each value in the Destination Compare array, attempt to find
' a match in the 'keys' of the dictionary, and write the associated 'item'
' to the same row of the Destination Value array.
Dim cr As Long, NrCamion As String
For cr = 1 To crCont
NrCamion = CStr(ccData(cr, 1))
If fDict.Exists(NrCamion) Then cvData(cr, 1) = fDict(NrCamion)
Next cr
' Write the values from the Destination Value array
' to the Destination Value range.
crg.Value = cvData
End Sub

How do I code a macro in VBA that deletes columns in excel that don't appear in an array?

I'm creating a macro that is formatting a collection of files and a step in this process is to delete columns that aren't required, keeping a specific set of columns.
I know I can delete columns based on their location and I have this approach implemented already ie 1,3,7 etc or A, C, G etc. But I'm conscious that the report being used might change layout or add extra columns over time and I want to ensure the required columns are kept.
Ideally this code would cycle through each column header starting at A1 until the last column and delete an entire column if the header value isn't found in a list. This list will be an array captured from a range in one of the sheets in the workbook.
List = {Blue, Green, Orange}
Original Table
Blue
Red
Green
Orange
Black
row
row
row
row
row
Formatted Table
Blue
Green
Orange
row
row
row
Does anyone have any suggestions on the approach I could take to get this working or if it's even possible? Any help would be greatly appreciated
You might profit from the following approach by reordering a datafield array via Application.Index which allows even to move the existing columns to any new position.
Note: this flexible solution can be time consuming for greater data sets,
where I would prefer other ways you can find in a lot of answers at SO.
Sub ReorderColumns()
Const headerList As String = "Blue,green,Orange"
'a) define source range
Dim src As Range
Set src = Tabelle3.Range("A1:E100")
'b) define headers
Dim allHeaders: allHeaders = src.Resize(1).Value2
Dim newHeaders: newHeaders = Split(headerList, ",")
'c) get column positions in old headers
Dim cols
cols = getCols(newHeaders, allHeaders)
'd) define data
Dim data As Variant
data = src.Value2
'e) reorder data based on found column positions
data = Application.Index(data, Evaluate("row(1:" & UBound(data) & ")"), cols)
'f) overwrite source data
src = vbNullString ' clear
src.Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help function getCols()
Function getCols(individualHeaders, allHeaders)
'Purp: get 1-based column numbers of found headers via Match
getCols = Application.Match(individualHeaders, allHeaders, 0) ' 1-based
End Function
Please, test the next code. It is compact and fast enough. It will build the columns to be deleted range using Application.Match for the two involved arrays (the existing headers one and the ones to be kept). This code assumes that the headers exist in the first row of the processed sheets, starting from A:A column (If starting from a different column, the code can be adapted:
Sub DeleteColunsNotInArrayDel()
Dim sh As Worksheet, arrStay, lastCol As Long, arrH, arrCols, rngDel As Range
Set sh = ActiveSheet 'use here the sheet you need to process
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
arrH = Application.Transpose(Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2)) 'existing headers array
arrCols = Application.IfError(Application.match(arrH, arrStay, 0), "xx") 'match the two arrays and place "xx" where no match has been found
makeColsRng(arrCols).Delete 'delete the columns range, at once
End Sub
Function makeColsRng(arr) As Range
Dim i As Long, colL As String, strAddr As String
For i = LBound(arr) To UBound(arr) 'iterate between the matched arrays array
If arr(i) = "xx" Then 'for the not matching case:
colL = Split(cells(1, i).Address, "$")(1) 'extract the letter of the respective column
strAddr = strAddr & colL & "1," 'build the string of the columns to be deleted range
End If
Next i
Set makeColsRng = Range(left(strAddr, Len(strAddr) - 1)).EntireColumn 'return the necessary range
End Function
In case of headers not starting from the first sheet column, the function can easily be adapted by adding a new parameter (the first column number) to be added when the range to be deleted is built.
The above suggested solution is a fancy one, just for the sake of showing the respective approach, which is not too often used. It may have a limitation of the range building, in case of a string bigger than 254 digits, No error handling for the case of everything matching (even, easy to be added). The next version is standard VBA, compact, more reliable, faster and easier to be understood:
Sub DeleteColunsRangeNotInArray()
Dim sh As Worksheet, arrStay, lastCol As Long, rngH As Range, rngDel As Range, i As Long
Set sh = ActiveSheet
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
Set rngH = sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)) 'existing headers range
For i = 1 To rngH.Columns.count
If IsError(Application.match(rngH(i).Value, arrStay, 0)) Then 'if not a match in arrStay:
addToRange rngDel, rngH(i) 'build a Union range
End If
Next i
'delete the not necessary columns at once:
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Dynamic Named Range
I think a dynamic named range is an excellent choice for storing and retrieving your required columns. Please see the link I provided from https://exceljet.net/ to setup your dynamic named range.
Generic formula =$A$2:INDEX($A:$A,COUNTA($A:$A))
Regular Expression Approach
After reading in your named range, one approach for testing your columns is using regular expressions. To use this you will need to set a library reference to Microsoft VBScript Regular Expressions 5.5. The pipe character | represents an or statement, so we can join our array using that delimiter.
Deleting Ranges in loops
When deleting columns or rows within a loop, the best approach I have found is to union the ranges together in a variable and execute the deletion in one go. This helps performance and it prevents errors from deleting ranges the loop is working on.
I do this so often that I created a custom function for this UnionRange
' Helper function that allows
' concatinating ranges together
Public Function UnionRange( _
ByRef accumulator As Range, _
ByRef nextRange As Range _
)
If accumulator Is Nothing Then
Set UnionRange = nextRange
Else
Set UnionRange = Union(accumulator, nextRange)
End If
End Function
Putting it all together
Below is my implementation of what your code could look like, just make sure to first:
Create a Dynamic Named Range and populate with your required headers
Add Microsoft VBScript Regular Expressions 5.5 reference
Update Sheet1 to whatever sheet your table exists (possibly change logic for finding header row based on your needs)
' Need Regular Expressions Referenced in order to work!
' #libraryReference {Microsoft VBScript Regular Expressions 5.5}
Public Sub DemoDeletingNonRequiredColumns()
' Make sure to create a named range
' otherwise this section will fail. In this
' example the named range is `RequiredColumns`
Dim requiredColumns() As Variant
requiredColumns = Application.WorksheetFunction.Transpose( _
Range("RequiredColumns").Value2 _
)
' To test if the column is in the required
' columns this method uses regular expressions.
With New RegExp
.IgnoreCase = True
' The pipe charactor is `or` in testing.
.Pattern = Join(requiredColumns, "|")
Dim headerRow As Range
' This example uses `Sheet1`, but update to
' the actual sheet you are using.
With Sheet1
Set headerRow = .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
End With
Dim column As Range
For Each column In headerRow
' If the column name doesn't match the
' pattern, then concatenate it to the
' toDelete range.
If Not .Test(column.Value2) Then
Dim toDelete As Range
Set toDelete = UnionRange(toDelete, column.EntireColumn)
End If
Next
End With
' toDelete is used as it provides better performance
' and it also prevents errors when deleting columns
' while looping.
If Not toDelete Is Nothing Then
toDelete.Delete
Set toDelete = Nothing
End If
End Sub
Delete Columns Not In a List
Option Explicit
Sub DeleteIrrelevantColumns()
' Source - the worksheet containing the list of headers.
Const sName As String = "Sheet2"
Const sFirstCellAddress As String = "A2"
' Destination - the worksheet to be processed.
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim sData() As Variant
With sfCell
Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
sData = .Resize(slCell.Row - .Row + 1).Value
End With
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim sValue As Variant
Dim sr As Long
For sr = 1 To UBound(sData)
sValue = sData(sr, 1)
If Not IsError(sValue) Then ' exclude error values
If Len(sValue) > 0 Then ' exclude blanks
sDict(sValue) = Empty ' write
End If
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range
With dfCell
Dim dlCell As Range: Set dlCell = _
.Resize(, dws.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
Set drg = .Resize(, dlCell.Column - .Column + 1)
End With
Dim dData() As Variant: dData = drg.Value
Dim dCells As Range
Dim dValue As Variant
Dim dc As Long
For dc = 1 To UBound(dData, 2)
dValue = dData(1, dc)
If sDict.Exists(dValue) Then
' If duplicate columns, keep only the left-most.
sDict.Remove dValue
Else
' Combine the irrelevant header cells into a range.
If dCells Is Nothing Then
Set dCells = drg.Cells(dc)
Else
Set dCells = Union(dCells, drg.Cells(dc))
End If
End If
Next dc
' Delete columns in one go.
If Not dCells Is Nothing Then
dCells.EntireColumn.Delete
End If
' Inform.
If sDict.Count = 0 Then
MsgBox "Irrelevant columns deleted.", vbInformation
Else
MsgBox "Irrelevant columns deleted." & vbLf & vbLf _
& "Columns not found:" & vbLf _
& Join(sDict.Keys, vbLf), vbCritical
End If
End Sub

Incompatibility type when using range

I'm trying to to run a command if these arguments checks , but it's giving me incompatibily type on that block, what am I doing wrong?
Dim rn as range
For Each rg In Columns("X")
If rg.Value Like "?*#?*.?*" And _
LCase(Cells(rg.Row, "U").Value) = "Demande de création d'intervention" _
And LCase(Cells(rg.Row, "V").Value) <> "envoyé" Then
Comparing Strings
If you loop through the cells of the whole column, it will take forever. Calculate the last row, the row of the last non-empty cell in the column, instead.
LCase(Something) will never be equal to Demande.... Use demande... instead.
If you use CStr to convert a value to a string, you won't have to worry about the value being incompatible when comparing it to another string.
The Code
Option Explicit
Sub Test()
Const FirstRow As Long = 2
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "X").End(xlUp).Row
' If LastRow < FirstRow Then
' MsgBox "No data in column.", vbCritical
' Exit Sub
' End If
' Reference the column range ('rg').
Dim rg As Range
Set rg = ws.Range(ws.Cells(FirstRow, "X"), ws.Cells(LastRow, "X"))
' Reference the other column ranges ('rg2', 'rg3')
Dim rg2 As Range: Set rg2 = rg.EntireRow.Columns("U")
Dim rg3 As Range: Set rg3 = rg.EntireRow.Columns("V")
' Note that all three ranges are of the same size.
' Declare additional variables to be use in the loop.
Dim Cell As Range ' Current cell in the first range
Dim cString As String ' String Representation of the Current Cell's Value
Dim r As Long ' Index of the Current Cell
' Use 'CStr' to convert the values to strings to avoid an error occurring
' if the cell contains an error value.
For Each Cell In rg.Cells ' note '.Cells'
r = r + 1 ' count the cells (in this case rows)
cString = CStr(Cell.Value)
If cString Like "?*#?*.?*" _
And LCase(CStr(rg2.Cells(r).Value)) _
= "demande de création d'intervention" _
And LCase(CStr(rg3.Cells(r).Value)) <> "envoyé" Then
' Do your thing, e.g.
Debug.Print r, cString
End If
Next Cell
End Sub
Results in the Immediate window (Ctrl+G).
8 FY#I.NV
11 MF#X.UT
14 EU#X.IF

Search for a match, copy entire row, and paste to corresponding

Col B on "Sheet2" contains 370 rows of data.
Starting with "Sheet2" Cell B1, I want to search for a matching value in Col B on "Sheet1" (it could be located anywhere in the first 300 rows of "Sheet1" Col B).
If a match is found, copy the entire row from "Sheet1" and paste to Row1 on "Sheet2". Then, move to "Sheet2" Cell B2 and repeat the search, this time pasting the entire row from "Sheet1" to Row2 on "Sheet2". Continue moving thru the entire column of data on "Sheet2", searching for each cell's value on "Sheet1". If a search doesn't return a match, then do not paste anything to that row on "Sheet2" and just proceed to search for the next cell on "Sheet2". (For example, if Sheet1 Col B doesn't contain a match for Sheet2 Cell B3, then nothing gets pasted in Sheet2 Row3.)
I have found the following example, which starts to help me, but it specifies the search value and doesn't loop thru the entire column of values like I am attempting to do.
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
J = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("E1:E1000") ' Do 1000 rows
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
This should do the trick, and do it fast:
Option Explicit
Sub CopyYes()
'You need Microsoft Scripting Runtime library under Tools-References for this
Dim arrPaste As Variant: arrPaste = Sheet2.UsedRange.Value
Dim arrCopy As Variant: arrCopy = Sheet1.UsedRange.Value
Dim MyMatches As New Dictionary: Set MyMatches = CreateDictionary(arrCopy)
Dim i As Long
For i = 1 To UBound(arrPaste)
If arrPaste(i, 2) = vbNullString Then Exit For
If MyMatches.Exists(arrPaste(i, 2)) Then PasteData arrPaste, arrCopy, i, MyMatches(arrPaste(i, 2))
Next i
Sheet2.UsedRange.Value = arrPaste
Erase arrCopy
Erase arrPaste
End Sub
Private Function CreateDictionary(arr As Variant) As Dictionary
Dim i As Long
Set CreateDictionary = New Dictionary
For i = 1 To 300
CreateDictionary.Add arr(i, 2), i
Next i
End Function
Private Sub PasteData(arrPaste As Variant, arrCopy As Variant, i As Long, MyMatch As Long)
Dim j As Long
For j = 1 To UBound(arrCopy, 2)
If arrCopy(MyMatch, j) = vbNullString Then Exit For
arrPaste(i, j) = arrCopy(MyMatch, j)
Next j
End Sub
Use Range.Find to search for your matching cell
Use a Union to create a collection of the rows that are found
Once your loop is finished, copy your range all at once if the Union is not empty
Sub Shelter_In_Place()
Dim Source As Worksheet: Set Source = ThisWorkbook.Sheets("Sheet1")
Dim Target As Worksheet: Set Target = ThisWorkbook.Sheets("Sheet2")
Dim Found As Range, lr As Long
Dim CopyMe As Range
lr = Target.Range("B" & Target.Rows.Count).End(xlUp).Row
For i = 1 To lr
Set Found = Source.Range("B:B").Find(Target.Range("B" & i), LookIn:=xlWhole)
If Not Found Is Nothing Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, Target.Range("B" & i))
Else
Set CopyMe = Target.Range("B" & i)
End If
End If
Set Fouund = Nothing
Next i
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy
Source.Range("A1").PasteSpecial xlPasteValues
End If
End Sub

How can I place a formula in the first empty cell on Column F?

How can I place a formula in the first empty cell on Column F?
F3 is empty cell.
Need for that empty cell be =F2
Note: I'm looking for code to look for first empty cell F and I need to be able to insert in the first empty cell =F3.
Currently working with following code copied from here
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
sourceCol = 6 'column F has a value of 6
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell and select it
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Select
Exit For 'This is missing...
End If
Next
Your existing code implies you want to consider truely Empty cells and cells that contain an empty string (or a formula that returns an empty string) Note 1. (Given you simply copied that code from elsewhere, that may not be the case)
You can use End(xlDown) to locate the first truely Empty cell, or Match to locate the first "Empty" cell in a range (either just empty string, or either empty strings or Empty cells, in different forms)
If you want to find the first truely Empty cell, or cell containing an empty string:
Function FindFirstEmptyOrBlankCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty or blank cell
Set FindFirstEmptyOrBlankCell = rng.Cells(StartingAt.Worksheet.Evaluate("Match(True, " & rng.Address & "=""""" & ", 0)"), 1)
End Function
If you want to find the first truely Empty cell, and ignore cells containing an empty string:
Function FindFirstEmptyCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty cell
If IsEmpty(StartingAt.Cells(1, 1)) Then
Set FindFirstEmptyCell = rng.Cells(1, 1)
ElseIf IsEmpty(StartingAt.Cells(2, 1)) Then
Set FindFirstEmptyCell = rng.Cells(2, 1)
Else
Set FindFirstEmptyCell = rng.End(xlDown).Cells(2, 1)
End If
End Function
And for completeness, if you want to find the fisrt cell containing an empty string, and ignore truely Empty cells:
Function FindFirstBlankCell(StartingAt As Range) As Range
Dim rng As Range
Dim idx As Variant
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first blank cell
idx = Application.Match(vbNullString, rng, 0)
If IsError(idx) Then
'There are no Blank cells in the range. Add to end instead
Set FindFirstBlankCell = rng.Cells(rng.Rows.Count, 1)
Else
Set FindFirstBlankCell = rng.Cells(idx, 1)
End If
End Function
In all cases, call like this
Sub Demo()
Dim ws As Worksheet
Dim r As Range
Set ws = ActiveSheet '<~~~ or specify required sheet
Set r = FindFirstEmptyOrBlankCell(ws.Range("F3"))
' literally what was asked for
'r.Formula = "=F3"
' possibly what was actually wanted
r.Formula = "=" & r.Offset(-1, 0).Address(0, 0)
End Sub
Note 1
If IsEmpty(currentRowValue) Or currentRowValue = "" Then is actually redundant. Any value that returns TRUE for IsEmpty(currentRowValue) will also return TRUE of currentRowValue = "" (The reverse does not apply)
From comment can that same Fuction repeat until the last empty cel? I think this is what you mean is to continue to fill blank cells down through the used range
If so, try this
Sub Demo()
Dim ws As Worksheet
Dim cl As Range
Dim r As Range
Set ws = ActiveSheet '<~~~ or specify required sheet
Set cl = ws.Range("F3")
Do
Set r = FindFirstEmptyOrBlankCell(cl)
If r Is Nothing Then Exit Do
r.Formula = "=" & r.Offset(-1, 0).Address(0, 0)
Set cl = r.Offset(1, 0)
Loop
End Sub
Note, I've modified FindFirstEmptyOrBlankCell above to aloow it to return Nothing when it needs to:
Function FindFirstEmptyOrBlankCell(StartingAt As Range) As Range
Dim rng As Range
'Set search range
With StartingAt.Worksheet
Set rng = .Range(StartingAt, .Cells(.Rows.Count, StartingAt.Column).End(xlUp).Offset(1, 0))
End With
' Find first empty or blank cell
On Error Resume Next ' Allow function to return Nothing
Set FindFirstEmptyOrBlankCell = rng.Cells(StartingAt.Worksheet.Evaluate("Match(True, " & rng.Address & "=""""" & ", 0)"), 1)
End Function
You'll need to change your rowCount, the way you have it, the loop will stop before the first blank row. I believe you should just be able to set use .Formula for the empty cell. Hope this helps:
Sub EmptyCellFillFormula()
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
sourceCol = 6 'column F has a value of 6
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row + 1
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Formula = "=F3"
End If
Next
End Sub

Resources