I'm trying to do a cycle, where IF the condition is true and cell n index (column E) is the same as cell's n+1 index, to copy the column C value into column G.
Unfortunately last C column value is not copied to column G, so i simply resolved it with a string:
Sheets("Report KIT").Range("G" & n) = Sheets("Report KIT").Range("C" & n).Value
after Do While. Can anyone help with it please? Thanks
Sub Macroarea1()
Dim ws As Worksheet
Dim LastRow As Long
Dim LastRow1 As Long, LastRow3 As Long
Dim i, n As Integer, x As Integer, y As Integer
Set ws = ActiveWorkbook.Sheets("Report KIT")
If Sheets("Migrazioni").Range("F" & 7) = "si" Then
n = Sheets("Migrazioni").Range("N" & 7).Value
Do While _
Sheets("Report KIT").Range("E" & n) = Sheets("Report KIT").Range("E" & n + 1)
Sheets("Report KIT").Range("G" & n) = Sheets("Report KIT").Range("C" & n).Value
n = n + 1
Loop
Sheets("Report KIT").Range("G" & n) = Sheets("Report KIT").Range("C" & n).Value
End If
End Sub
I cleaned up your looping a bit and added a check for the E column value first and modified the loop to check to make sure each row meets the initial E column value to test it. I tested this with your sample data it produced the result you wanted. Sometimes these conditional loops can be tricky to figure out!
Sub Macroarea1()
Dim wsR As Worksheet, wsN As Worksheet
Dim LastRow As Long
Dim LastRow1 As Long, LastRow3 As Long
Dim i, n As Integer, x As Integer, y As Integer
Set wsR = ActiveWorkbook.Sheets("Report KIT")
Set wsN = ActiveWorkbook.Sheets("Migrazioni")
If wsN.Range("F7") = "si" Then
n = wsN.Range("N7").Value
i = wsR.Range("E" & n).Value
Do Until wsR.Range("E" & n) <> i
wsR.Range("G" & n).Value = wsR.Range("C" & n).Value
n = n + 1
Loop
End If
End Sub
Related
I am looking to do a vlookup via a dictionary in a VBA Macro. I have seen a few examples around the internet but they are mostly very specific and I am hoping to get assistance with more "bare bones" code. I will use a simple example of what I would like to achieve:
Lookup Value to be each cell within a dynamic range starting in cell B2 on the "Orders" Worksheet (bottom row varies)
Table Array to be on a dynamic range starting in cell E2 and extending to column L on the "Report" Worksheet (Bottom row varies)
Column Index Number is to be 8 (Column L)
Range Lookup is to be False
My current code is below:
Sub DictionaryVLookup()
Dim x, y, z(1 To 10)
Dim i As Long
Dim dict As Object
Dim LastRow As Long
LastRow = Worksheets("Report").Range("B" & Rows.Count).End(xlUp).Row
x = Sheets("Orders").Range("B2:B" & LastRow).Value
y = Sheets("Report").Range("E2:E" & LastRow).Value 'looks up to this range
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = x(i, 1)
Next i
For i = 1 To UBound(y, 1)
If dict.exists(y(i, 1)) Then
z(i) = y(i, 1)
Else
z(i) = "NA"
End If
Next i
Worksheets("Orders").Range("Z2:Z" & LastRow).Value = Application.Transpose(z) 'this is where the values are placed
End Sub
I seem to be missing the "lookup" portion, currently this runs without error and simple places the values which are "found" by the lookup, but I don't know how to have the returned value be offset (want to return column L in this example).
Also I did some "Frankenstein" work with this code - so I am not sure why this is present:
Dim x, y, z(1 To 10)
the (1 to 10) I will want to be dynamic I would guess.
This is my first attempt at using a dictionary in this fashion - Hoping to get a basic understanding through this simple example which I can then implement into more involved situations.
I know there are other methods to do what I am describing, but looking to learn specifically about dictionaries.
Thanks in advance for any assistance !
Something like this:
Sub DictionaryVLookup()
Dim x, x2, y, y2()
Dim i As Long
Dim dict As Object
Dim LastRow As Long, shtOrders As Worksheet, shtReport As Worksheet
Set shtOrders = Worksheets("Orders")
Set shtReport = Worksheets("Report")
Set dict = CreateObject("Scripting.Dictionary")
'get the lookup dictionary from Report
With shtReport
LastRow = .Range("E" & Rows.Count).End(xlUp).Row
x = .Range("E2:E" & LastRow).Value
x2 = .Range("L2:L" & LastRow).Value
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = x2(i, 1)
Next i
End With
'map the values
With shtOrders
LastRow = .Range("B" & Rows.Count).End(xlUp).Row
y = .Range("B2:B" & LastRow).Value 'looks up to this range
ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array
For i = 1 To UBound(y, 1)
If dict.exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = "NA"
End If
Next i
.Range("Z2:Z" & LastRow).Value = y2 '<< place the output on the sheet
End With
End Sub
Generalized #Tim Williams excellent example to have no Hard coded ranges in main sub for helping following users.
'In sheet Phones lookup col F at LogFileSh sheet col CE,CF and return
'the results in col D sheet Phones. Row of F+D is 2 and row CE+CF is 2.
Sub RunDictionaryVLookup()
Call GeneralDictionaryVLookup(Phones, LogFileSh, "F", "CE", "CF", "D", 2, 2)
End Sub
Sub GeneralDictionaryVLookup(ByVal shtResault As Worksheet, ByVal shtsource As Worksheet, _
ByVal colLOOKUP As String, ByVal colDicLookup As String, ByVal colDicResault As String, ByVal colRESULT As String, _
ByVal rowSource As Long, ByVal rowResult As Long)
Dim x As Variant, x2 As Variant, y As Variant, y2() As Variant
Dim i As Long
Dim dict As Object
Dim LastRow As Long
Set dict = CreateObject("Scripting.Dictionary")
'get the lookup dictionary
With shtsource
LastRow = .Range(colDicLookup & Rows.Count).End(xlUp).row
x = .Range(colDicLookup & rowSource & ":" & colDicLookup & LastRow).Value
x2 = .Range(colDicResault & rowSource & ":" & colDicResault & LastRow).Value
For i = 1 To UBound(x, 1)
dict.item(x(i, 1)) = x2(i, 1)
Debug.Print dict.item(x(i, 1))
Next i
End With
'map the values
With shtResault
LastRow = .Range(colLOOKUP & Rows.Count).End(xlUp).row
y = .Range(colLOOKUP & rowResult & ":" & colLOOKUP & LastRow).Value 'looks up to this range
ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array
For i = 1 To UBound(y, 1)
If dict.Exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = "NA"
End If
Next i
.Range(colRESULT & rowResult & ":" & colRESULT & LastRow).Value = y2 '<< place the output on the sheet
End With
End Sub
I have two sheets – Latency, TP. I need to copy col M from "Latency" and paste it into col D of "TP" only if "Latency" col E has the string “COMPATIBLE” and col O has the string “Pass”.
I have the below code, but it doesn't give any result.
I'm not sure whats wrong with it:
Sub sbMoveData()
Dim lRow As Integer, i As Integer, j As Integer
'Find last roe in Sheet1
With Worksheets("Latency")
lRow = .Cells.SpecialCells(xlLastCell).Row
j = 1
For i = 1 To lRow
If UCase(.Range("E" & i)) = "COMPATIBLE" And UCase(.Range("O" & i)) = "Pass" Then
.Range("M" & i).Copy Destination:=Worksheets("TP").Range("D" & j)
j = j + 1
End If
Next
End With
End Sub
UCase(.Range("O" & i)) = "Pass"
Will always be false :-)
You are never going to match UCase(Cell) = "Pass", right? You either need to have:
UCase(.Range("O" & i)) = "PASS"
or
.Range("O" & i) = "Pass"
Try this
Sub sbMoveData()
Dim lRow As Integer, i As Integer, j As Integer
Dim ws1, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Latency")
Set ws2 = ThisWorkbook.Sheets("TP")
'Find last roe in Sheet1
lRow = ws1.Cells.SpecialCells(xlLastCell).Row
j = 1
For i = 1 To lRow
If ws1.Range("A" & i) = "COMPATIBLE" And ws1.Range("B" & i) = "Pass" Then
ws1.Range("M" & i).Copy Destination:=ws2.Range("D" & j)
j = j + 1
End If
Next i
End Sub
column A and Column C is the range and column B is the reference value which I have to compare with Column A and Column C .
Eg: (B>A) and (B
Basically I want to check whether column B falls between Column A and column C
Here is the code which I have prepared but this is not working and this is for single cell:
Sub a()
Dim x As Integer
Dim y As Integer
x = Worksheets("Sheet1").Range("A1").Value
y = Worksheets("Sheet1").Range("B1").Value
Z = Worksheets("Sheet1").Range("C1").Value
If Z > x Then
Worksheets("Sheet1").Range("D1") = "Correct"
End If
End Sub
you can do this way:
Sub main()
With Worksheets("Sheet1")
With .Range("D1:D" & .Cells(.Rows.Count, 1).End(xlUp).row)
.FormulaR1C1 = "=IF(AND(RC2>=RC1,RC2<=RC3),""Correct"",""Wrong"")"
.Value = .Value
End With
End With
End Sub
You can use a simple formula for this:
=IF(AND(B1>=A1,B1<=C1),"Correct","Wrong")
If you still need vba then use this:
Sub RANGEFALL()
Dim wk As Worksheet, frow As Long, i As Long
Set wk = Sheet1
frow = wk.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To frow
If wk.Range("B" & i).Value >= wk.Range("A" & i).Value And wk.Range("B" & i).Value <= wk.Range("C" & i).Value Then
wk.Range("D" & i).Value = "Correct"
Else
wk.Range("D" & i).Value = "Wrong"
End If
Next i
End Sub
I have the following VBA code:
Sub test():
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2"): Set w2 = Sheets("Sheet3")
GetNameValue: For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1: Do Until w1.Range("A" & j) = "DATE OF BIRTH:": j = j + 1: Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1: End If
GetNext: Next i: NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|"): j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1): w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
To break down what this code does:
1) Set the first sheet that should be searched and the second sheet (output sheet) that the results should be appended to.
2) Search the first column for a certain string "NAME:" and once found take the value in the second column, place it in the output sheet go look for "DATE OF BIRTH:". Once "DATE OF BIRTH:" is found put it beside the value for "NAME:" in the output sheet.
3) Repeat until there are no more entries.
I'm sure this is a very simple modification, but what I'd like to do is check whether a certain string exists, if it does grab the entry directly BELOW it, and then continue searching for the next string and associated entry just like the code does already.
Can anyone point me to what I would need to change in order to do this (and preferably why)?
In addition, how might I be able to extend this code to run over multiple sheets while depositing the results in a single sheet? Do I need to set up a range running over the worksheets w_1....w_(n-1) (with output sheet w_n possibly in a different workbook)?
Removed Line continuations in code:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
UPDATE: Just to make sure we're all on the same page about what the output would look like. Suppose we are searching for the entry below A and the entry beside C:
INPUT
A 1
B
y 3
z 4
t
d
s 7
C 8
A 1
Z
y 3
z 4
t
d
s 7
C 12
OUTPUT
B 8
Z 12
.
.
.
Assuming I understand your desire correctly, you can use the .Offset method with your current range to get to the cell below it. You would need to add a dim, so here's my stab at what you're trying to accomplish:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
'new local variable
Dim newValue as string
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
'assuming your string is in column A
If w1.Range("A" & i) = "FIND ME" Then
newValue = w1.Range("A" & i).Offset(1,0).Value
End If
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Then you could do anything you desired with the newValue string, including putting it in w2 like so: w2.Range("D1").value = newValue
UPDATED ANSWER
I am now 89% sure I know what you are trying to accomplish :) thanks for your clarifying example.
To search a range for your search string, you need to set up a range you are looking in:
dim searchRange as range
dim w1,w2 as worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
set searchRange = w1.Range("A" & Rows.Count).End(xlUp).Row
Then you search the searchRange for both of your search strings (which I'm saying are "A" for the first and "C" for the second). As long as both strings are found in the searchRange, it will create a new Dictionary entry for the two values, having the value below "A" as the key and the value beside "C" as the item.
dim rng as range
dim valueBelowFirstSearch as string
dim resultsDictionary as object
dim i as integer
dim c, d as range
dim cAddress, dAddress as string
set resultsDictionary = CreateObject("scripting.dictionary")
with searchRange
set c = .Find("A", lookin:=xlValues)
set d = .Find("C", lookin:=xlValues)
if not c Is Nothing and not d Is Nothing then
cAddress = c.address
dAddress = d.address
resultsDictionary.add Key:=c.offset(1,0).value, Item:=d.value
Do
set c = .FindNext(c)
set d = .FindNext(d)
Loop While not c is nothing and not d is nothing and c.address <> cAddress and d.address <> dAddress
end if
end with
Now that we have all of the results in the resultsDictionary, we can now output the values into another place, which I'm choosing to be w2.
dim outRange as range
dim item as variant
set outRange = w2.Range("A1")
for each item in resultsDictionary
outRange.Value = item.key
set outRange = outRange.Offset(0,1)
outRange.Value = item.item
set outRange = outRange.Offset(1,-1)
next item
Can anyone point me to what I would need to change in order to do this
(and preferably why)?
Basically you need to change the parts of which NameValue is composed.
Originally you took the value beside the first match as w1.Range("B" & i) and now you want the value below the first match, which is w1.Range("A" & i + 1).
Originally it was:
Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
Now you need something like this:
Trim(NameValue & " " & w1.Range("A" & i + 1) & "|" & w1.Range("B" & j))
In addition, how might I be able to extend this code to run over
multiple sheets while depositing the results in a single sheet?
(with output sheet w_n possibly in a different workbook)?
To achieve that you can e.g. create an array of Sheets and let the code run for each Sheet of this array. Note that the array might contain 1-N Sheets.
' Set array of sheets for just one sheet
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1"))
' Set array of sheets for more sheets, e.g. "Sheet1" and "Sheet2" and "Sheet3"
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
' Finally set the second sheet where the results should be appended
' to sheet in the same workbook as the searched sheets
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeBook.xlsx").Worksheets("ResultSheet")
' Or set the second sheet where the results should be appended to sheet
' in a different workbook then the searched sheets belong to
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
The complete code might look like this (tested with data you provided).
Option Explicit
Public Sub main()
' String to search below of it
Dim string1 As String
string1 = "A"
' String to search beside of it
Dim string2 As String
string2 = "C"
' Set the sheets that should be searched
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2"))
' Set the second sheet (outputSheet sheet) that the results should be
' appended to external sheet in different book
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
SearchFor string1, string2, searchedSheets, outputSheet
End Sub
Public Sub SearchFor( _
string1 As String, _
string2 As String, _
searchedSheets As Sheets, _
output As Worksheet)
Dim searched As Worksheet
Dim NameValue As String
Dim below As String
Dim beside As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim rowsCount As Long
For Each searched In searchedSheets
rowsCount = searched.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To rowsCount
' Search the first column for a 'string1'
If searched.Range("A" & i) = string1 Then
' once 'string1' was found grab the entry directly below it
below = searched.Range("A" & i + 1)
If InStr(1, NameValue, below) Then
' skip this 'below' result because it was found before
GoTo GetNext
End If
' Search the first column for a 'string2' starting at the
' position where 'below' was found
For j = i + 1 To rowsCount
If searched.Range("A" & j) = string2 Then
' once 'string2' was found grab the entry directly
' beside it
beside = searched.Range("B" & j)
Exit For
End If
Next j
' Append 'below' and 'beside' to the result and count the
' number of metches
NameValue = Trim(NameValue & " " & below & "|" & beside)
c = c + 1
End If
GetNext:
Next i
Next searched
' Write the output
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
output.Range("A" & k) = Left(NameValue, i - 1)
output.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Note: I replaced the Do-Until loop with For-Next loop because the Do-Until might cause a Stack-Overflow :-) error if the string "DATE OF BIRTH:" does not exist in the first column. However I have tryied to keep your originall code structure so you still understand it. HTH.
Assuming that you want to find one value (Name:), then continue searching till to find the second one (Date Of Birth:)... Finally, you want to move these pair of data into another worksheet.
To achieve that, i'd suggest to use Dictionary object to get only distinct values. I strongly do not recommend to use string concatenation as you provided in your code!
Option Explicit
Sub Test()
Dim src As Worksheet, dst As Worksheet
Set dst = ThisWorkbook.Worksheets("Sheet2")
For Each src In ThisWorkbook.Worksheets
If src.Name = dst.Name Then GoTo SkipNext
NamesToList src, dst
SkipNext:
Next
End Sub
'needs reference to MS Scripting Runtime library
Sub NamesToList(ByVal srcWsh As Worksheet, ByVal dstWsh As Worksheet, _
Optional ByVal SearchFor As String = "NAME:", Optional ByVal ThenNextFor As String = "DATE OF BIRTH:")
Dim dic As Dictionary, i As Long, j As Long, k As Long
Dim sKey As String, sVal As String
On Error GoTo Err_NamesToList
Set dic = New Dictionary
i = 2
j = GetFirstEmpty(srcWsh)
Do While i < j
If srcWsh.Range("A" & i) = SearchFor Then
sKey = srcWsh.Range("B" & i)
If Not dic.Exists(sKey) Then
Do While srcWsh.Range("A" & i) <> ThenNextFor
i = i + 1
Loop
sVal = srcWsh.Range("B" & i)
dic.Add sKey, sVal
k = GetFirstEmpty(dstWsh)
With dstWsh
.Range("A" & k) = sKey
.Range("B" & k) = sVal
End With
'sKey = ""
'sVal = ""
End If
End If
SkipNext:
i = i + 1
Loop
Exit_NamesToList:
On Error Resume Next
Set dic = Nothing
Exit Sub
Err_NamesToList:
Resume Exit_NamesToList
End Sub
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
Sample output:
Name DateOfBirth:
A 1999-01-01
B 1999-01-02
C 1999-01-03
D 1999-01-04
E 1999-01-05
I currently have this code
Sub TFS_Data_TC_Custody_Failed()
Dim bottomL As Integer
Dim x As Integer
bottomL = Sheets("TFS_Data_TC_Custody").Range("E" & Rows.Count).End(xlUp).Row: x = 3
Dim c As Range
For Each c In Sheets("TFS_Data_TC_Custody").Range("E2:E" & bottomL)
If c.Value = "Failed" Then
c.EntireRow.Copy Worksheets("TC_Custody_Failed").Range("A" & x)
x = x + 1
End If
Next c End Sub
I want to change the EntireRow to only copy selected Columns e.g. A,C,D of the rows that it has identified.
One possibility is to create another Range object and use the Intersect method to keep only columns A,C, and D of the EntireRow
Sub TFS_Data_TC_Custody_Failed()
Dim bottomL As Integer
Dim x As Integer
bottomL = Sheets("TFS_Data_TC_Custody").Range("E" & Rows.Count).End(xlUp).Row: x = 3
Dim c As Range
Dim copyRange As Range
For Each c In Sheets("TFS_Data_TC_Custody").Range("E2:E" & bottomL)
If c.Value = "Failed" Then
Set copyRange = Application.Intersect(c.EntireRow, _
Sheets("TFS_Data_TC_Custody").Range("A:A,C:D"))
copyRange.Copy Worksheets("TC_Custody_Failed").Range("A" & x)
x = x + 1
End If
Next c
End Sub
Personally I would construct my code entirely differently but here is one way of doing it based on what you have. I didn't fully understand where you are placing the copied data so you may need to amend that part.
Dim bottomL As Integer
Dim x As Integer
bottomL = Sheets("TFS_Data_TC_Custody").Range("E" & Rows.Count).End(xlUp).Row
x = 3
Dim c As Range
For Each c In Sheets("TFS_Data_TC_Custody").Range("E2:E" & bottomL)
If c.Value = "Failed" Then
c.Cells(1, 1).Copy Worksheets("TC_Custody_Failed").Range("A" & x)
c.Cells(1, 3).Copy Worksheets("TC_Custody_Failed").Range("A" & x + 1)
c.Cells(1, 4).Copy Worksheets("TC_Custody_Failed").Range("A" & x + 2)
x = x + 3
End If
Next c