I'm new to macros and VBA in Excel. Is there a way to check if the Testvalue is between Value 1 and Value 2, and move to the corresponding sheet? And if it's not, move to the next row and repeat.
E.g.
With the testvalue 3742 sheet A21 should be selected.
Simply iterate over each row until required condition is met:
Dim testVal As Long, r As Integer
Dim yourSheet As Worksheet
Set yourSheet = Sheet1
With yourSheet
testVal = .Range("E2").Value
r = 2
Do Until (.Range("A" & r).Value <= testVal) And _
(.Range("B" & r).Value >= testVal)
ThisWorkbook.Worksheets(.Range("C" & r).Value).Activate
r = r + 1
Loop
End With
In my opinion, instead of looping each row is faster if you use Find method.
Sub test()
Dim rngSearchA As Range, rngSearchB As Range, rngFoundA As Range, rngFoundB As Range
Dim strValue As String, strSheetName As String
Dim LastRowA As Long, LastRowB As Long
With ThisWorkbook.Worksheets("Sheet1")
strValue = .Range("E2").Value
strSheetName = ""
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rngSearchA = .Range("A2:A" & LastRowA)
Set rngSearchB = .Range("B2:B" & LastRowB)
Set rngFoundA = rngSearchA.Find(strValue, LookIn:=xlValues, Lookat:=xlWhole)
Set rngFoundB = rngSearchB.Find(strValue, LookIn:=xlValues, Lookat:=xlWhole)
If Not rngFoundA Is Nothing And Not rngFoundB Is Nothing Then
If .Range("C" & rngFoundA.Row).Value <> .Range("C" & rngFoundB.Row).Value Then
MsgBox "Searching value appears in both columns with different Sheet name."
Else
strSheetName = .Range("C" & rngFoundA.Row).Value
End If
ElseIf Not rngFoundA Is Nothing Or Not rngFoundB Is Nothing Then
If Not rngFoundA Is Nothing Then
strSheetName = .Range("C" & rngFoundA.Row).Value
Else
strSheetName = .Range("C" & rngFoundB.Row).Value
End If
Else
MsgBox "Value not found!"
End If
If strSheetName <> "" Then
ThisWorkbook.Worksheets(strSheetName).Activate
End If
End With
End Sub
Related
I am trying to find any cells with just spaces in. When I run this though it finds cells that are blanks too. Is there anyway to just find cells with spaces?
For i = 1 to lastRow
If len(trim(this workbook.sheets("data").range("a" & i)) = 0 then
Msgbox("a" & i " contains only space")
End if
Next i
Plase, try:
Sub testFindSpaces()
Dim wsD as Worksheet, i As Long, x As String, lastRow As Long
Set wsD = ThisWorkbook.Sheets("data")
lastRow = wsD.Range("A" & wsD.rows.count).End(xlUp).row
For i = 1 To lastRow
x = wsD.Range("a" & i).Value
If UBound(Split(x, " ")) = Len(x) Then
MsgBox "a" & i & " contains only space"
End If
Next i
End Sub
Just exclude blanks by testing for Len(ThisWorkbook.Worksheets("data").Range("A" & i)) <> 0 too.
For i = 1 to lastRow
Dim Untrimmed As String
Untrimmed = ThisWorkbook.Worksheets("data").Range("A" & i).Value
If Len(Trim(Untrimmed) = 0 AND Len(Untrimmed) <> 0 then
Msgbox "a" & i & " contains only space"
End if
Next i
Alternativeley use ThisWorkbook.Worksheets("data").Range("A" & i).Value <> vbNullString to exclude blanks
For i = 1 to lastRow
Dim Untrimmed As String
Untrimmed = ThisWorkbook.Worksheets("data").Range("A" & i).Value
If Len(Trim(Untrimmed) = 0 AND Untrimmed <> vbNullString then
Msgbox "a" & i & " contains only space"
End if
Next i
Just to add alternatives:
With ThisWorkbook.Sheets("data").Range("A" & i)
If .Value Like "?*" And Not .Value Like "*[! ]*" Then
MsgBox ("A" & i & " contains only space")
End If
End With
You may also just create a new regex-object and use pattern ^ +$ to validate the input.
If you don't want to loop the entire range but beforehand would like to exclude the empty cells you could (depending on your data) use xlCellTypeConstants or the numeric equivalent 2 when you decide to use SpecialCells() method and loop the returned cells instead:
Dim rng As Range, cl As Range
Set rng = ThisWorkbook.Worksheets("Data").Range("A:A").SpecialCells(2)
For Each cl In rng
If Not cl.Value Like "*[! ]*" Then
MsgBox ("A" & cl.Row & " contains only spaces")
End If
Next cl
You may also no longer need to find your last used row, but note that this may error out if no data at all is found in column A.
A last option I just thought about is just some concatenation before validation:
For i = 1 To lastRow
If "|" & Trim(ThisWorkbook.Sheets("data").Range("A" & i).value & "|" = "| |" Then
MsgBox ("A" & i & " contains only space")
End If
Next
Macro to get a string of address of cells containing only space using Evaluate VBA function
Edited code below - As suggested by #VBasic2008 and #T.M. in the comments below.
Option Explicit
Sub Cells_with_Space_Only()
Dim ws As Worksheet
Set ws = Sheets("Sheet2")
'Macro to get a string of address of cells containing only space
'https://stackoverflow.com/questions/68891170/finding-cells-with-only-spaces
Dim rngArr, rngStr As String, i As Long, rng As Range
rngArr = Evaluate("IFERROR(ADDRESS((ISBLANK(" & ws.UsedRange.Address(External:=True) & _
")=FALSE)*(" & ws.UsedRange.Address(External:=True) & _
"=REPT("" "",LEN(" & ws.UsedRange.Address(External:=True) & _
")))*ROW(" & ws.UsedRange.Address(External:=True) & _
"),COLUMN(" & ws.UsedRange.Address(External:=True) & ")),""**"")")
rngStr = ""
'If number of columns in usedrange are less then loop with
'For i = 1 To ActiveSheet.UsedRange.Columns.Count
For i = 1 To ws.UsedRange.Rows.Count
'if looped with For i = 1 To ActiveSheet.UsedRange.Columns.Count
'rngStr = Join(Filter(Application.Transpose(Application.Index(rngArr, 0, i)) _
, "**", False, vbBinaryCompare), ",")
rngStr = Join(Filter(Application.Index(rngArr, i, 0) _
, "**", False, vbBinaryCompare), ",")
If rngStr <> "" Then
If rng Is Nothing Then
Set rng = Range(rngStr)
Else
Set rng = Union(rng, Range(rngStr))
End If
End If
Next i
Debug.Print rng.Address
End Sub
The macro returns a string for the sample data in the image below --
$D$1,$A$2,$F$2,$B$3,$E$4,$A$6,$F$6,$E$7,$B$8,$D$9,$C$10,$F$10,$A$11,$D$13,$F$13,$E$14,$A$16,$E$16,$D$17,$F$17:$F$18
Array formula in the worksheet -
=IFERROR(ADDRESS((ISBLANK($A$1:$F$18)=FALSE)*($A$1:$F$18=REPT(" ",LEN($A$1:$F$18)))*ROW($A$1:$F$18),COLUMN($A$1:$F$18)),"**")
Clear Solo Spaces
Couldn't think of any reason for doing this other than for clearing the cells containing only spaces.
Option Explicit
Sub ClearSoloSpaces()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Data")
Dim srg As Range ' Source Range
Set srg = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim crg As Range ' Clear Range
Dim cCell As Range ' Current Cell in Source Range
Dim cString As String ' Current Cell's Value Converted to a String
For Each cCell In srg.Cells
cString = CStr(cCell.Value)
If Len(cString) > 0 Then
If Len(Trim(cString)) = 0 Then
If crg Is Nothing Then
Set crg = cCell
Else
Set crg = Union(crg, cCell)
End If
End If
End If
Next cCell
If crg Is Nothing Then
MsgBox "No cells containing only spaces found.", _
vbInformation, "Clear Solo Spaces"
Else
Dim Msg As Long
Msg = MsgBox("The cells in the rows '" _
& Replace(crg.Address, "$A$", "") _
& "' of column 'A' contain only spaces." & vbLf _
& "Do you want to clear them?", _
vbInformation + vbYesNo, "Clear Solo Spaces")
If Msg = vbYes Then
crg.Clear ' or crg.ClearContents ' to preserve formatting
End If
End If
End Sub
Just for the sake of showing alternatives (#T.M.), please test the next one, too:
Private Sub testFindSpacesBis()
Dim wsD As Worksheet, i As Long, x As String, lastRow As Long
Set wsD = ActiveSheet ' ThisWorkbook.Sheets("data")
lastRow = wsD.Range("A" & wsD.rows.count).End(xlUp).row
For i = 1 To lastRow
x = wsD.Range("a" & i).Value
If StrComp(x, space(Len(x)), vbBinaryCompare) = 0 Then
MsgBox "a" & i & " contains only spaces"
End If
Next i
End Sub
I am trying to build a macro that will match the ID between two sheets, then find the value and copy the header from scanned sheet to another.
The end result for SheetOne first couple of rows would be:
ID Month of No Month of Maybe Month of Yes
Row2: 1 January February March
Row3: 2 January March April
It needs to scan through columns (or any other way) at first for value "No", then for value "Maybe", then for value "Yes" and then copy the header of when the value first appeared. I've tried to just copy any value once ID's match, but that didn't work.
Screenshot of SheetOne:
Screenshot of SheetTwo:
I am in the beginning phase. This is my code so far:
Sub movingValues()
'declaring/setting variables
Dim SheetOneWs As Worksheet
Dim SheetTwoWs As Worksheet
Dim SheetOneLastRow As Long
Dim SheetTwoLastRow As Long
Dim SheetOneRng As Range
Dim SheetTwoRng As Range
Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)
'work process
For i = 2 To SheetOneLastRow
If SheetOneWs.Range(i, 1).Value = SheetTwoWs.Range(i, 1).Value Then
SheetTwoWs.Cells(i, 2).Copy
SheetOneWs.Activate
SheetOneWs.Cells(i, 2).Select
ActiveSheet.Paste
SheetTwoWs.Activate
End If
Next i
End Sub
ORIGINAL CODE
This should work:
Sub movingValues()
'declaring/setting variables
Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
Dim SheetOneRng As Range, SheetTwoRng As Range
Dim cell As Range, i As Integer
Application.Calculation = xlCalculationManual
Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)
SheetOneWs.Range("B2:D13").Value = ""
For i = 2 To SheetTwoLastRow
'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "No" Then
SheetOneWs.Cells(cell.Row, "B").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "B").Value = "No data"
Next cell
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "Maybe" Then
SheetOneWs.Cells(cell.Row, "C").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "C").Value = "No data"
Next cell
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "Yes" Then
SheetOneWs.Cells(cell.Row, "D").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "D").Value = "No data"
Next cell
Next i
Application.Calculation = xlCalculationManual
End Sub
I am working on cutting down the code into a single for loop so I'll update soon with better code, but the above code does the trick.
UPDATED CODE
I define a second Sub which checks the "No"s, "Maybe"s and "Yes"s, and this sub is called 3 times in the For loop.
Option Explicit
Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
Sub movingValues()
'declaring/setting variables
Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
Dim SheetOneRng As Range, SheetTwoRng As Range
Dim cell As Range, i As Integer
Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
Application.Calculation = xlCalculationManual
SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)
SheetOneWs.Range("B2:D13").Value = ""
For i = 2 To SheetTwoLastRow
'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
CheckValue "No", "B", i
CheckValue "Maybe", "C", i
CheckValue "Yes", "D", i
Next i
Application.Calculation = xlCalculationManual
End Sub
Sub CheckValue(checkString As String, colNum As String, i As Integer)
Dim cell As Range
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = checkString Then
SheetOneWs.Cells(cell.Row, colNum).Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, colNum).Value = "No data"
Next cell
End Sub
Some of your variables (SheetOneRng) are no longer required.
I adapted code I found online.
It finds the string "car" in column A and returns the rows as an array
It assigns a variable to the length of the array (how many matches it found)
It assigns a variable to generate a random number between 0 and the length of the array
It then prints a random matching row's value into K3
Dim myArray() As Variant
Dim x As Long, y As Long
Dim msg As String
With ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ReDim Preserve myArray(y)
myArray(y) = c.Row
y = y + 1
Set c = .findNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
For x = LBound(myArray) To UBound(myArray)
msg = msg & myArray(x) & " "
Next x
ArrayLen = UBound(myArray) - LBound(myArray)
random_index = WorksheetFunction.RandBetween(0, ArrayLen)
MsgBox myArray(random_index)
Dim test As String
test = "B" & myArray(random_index)
Range("K3").Value = Range(test)
Example
I'm struggling with adapting the find code to allow for multiple criteria. So in my example, it finds "Car". What if I want to find matches that had "Car" in column A and "Red" in column D?
I tried
With ActiveSheet.Range("A1:A" & "D1:D" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row & ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", "Red", LookIn:=xlValues)
I get type mismatch on the Set line.
In case it is confusing, it currently looks for a string e.g. "Car" but I will eventually link this to the variable which will be assigned to a data validation list. So if the user chooses "car" from a drop down list, this is what it will search for.
Maybe Advancde Filter is something that fit your needs:
Example Code
Option Explicit
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Edit according comment:
You can use the advanced filter and then loop through the filter results:
Option Explicit
Public CurrentRow As Long
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
CurrentRow = 1
On Error GoTo 0
End Sub
Public Sub GetNextResult()
FilterData
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
Dim FilteredData As Range
Set FilteredData = DataRange.Resize(ColumnSize:=1).SpecialCells(xlCellTypeVisible)
If CurrentRow + 1 > FilteredData.Cells.Count Then
CurrentRow = 1
End If
CurrentRow = CurrentRow + 1
Dim i As Long
Dim Cell As Variant
For Each Cell In FilteredData
i = i + 1
If i = CurrentRow Then
Cell.EntireRow.Select
'or
'MsgBox Cell.Value & vbCrLf & Cell.Offset(0, 1) & vbCrLf & Cell.Offset(0, 2) & vbCrLf & Cell.Offset(0, 3) & vbCrLf & Cell.Offset(0, 4)
End If
Next Cell
End Sub
The code below executes but the:
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
lastcell = .Range("B" & i).Value
End If
End If
Next i
Does not seem to be doing what I have intended. What I intended was that if the cell A & i's value = lets say rng1, if that is true then move on to the next parameter and check if that i's C column cell = rng2 if that is correct then take that row i's B column and set cell "C3" on the proof tab equal to B & i's value. Then move on to the next i; if it finds another B that fit the two conditions above, then set cell c3.offset(1) = to that i's value. This unfortunately is not working for me. ANyone have any suggestions :)
This is what it looks like when I run the code:
Sub Extract_Bank_Amount()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range, lastcell As Range
Dim lRow As Long, i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Bank Statement")
Set rng1 = wb.Sheets("Payroll Journal").Range("B1")
Set rng2 = wb.Sheets("Payroll Journal").Range("B3")
Set lastcell = wb.Sheets("Proof").Range("C3" & Rows.Count).End(xlUp).Offset(1)
wb.Sheets("Bank Statement").Activate
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
lastcell = .Range("B" & i).Value
End If
End If
Next i
End With
End Sub
You need to find the next empty cell each time you add a value to the end of the list.
Sub Extract_Bank_Amount()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range, lastcell As Range
Dim lRow As Long, i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Bank Statement")
Set rng1 = wb.Sheets("Payroll Journal").Range("B1")
Set rng2 = wb.Sheets("Payroll Journal").Range("B3")
wb.Sheets("Bank Statement").Activate
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Range("A" & i).Value = rng1 Then
If .Range("C" & i).Value = rng2 Then
With wb.Sheets("Proof")
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Value = .Range("B" & i).Value
End With
End If
End If
Next i
End With
End Sub
I would give the ranges on "Payroll Journal" meaningful names then used their Defined Names to refer to them.
wb.Sheets("Payroll Journal").Range("B1").Name = "PayrollB1"
wb.Sheets("Payroll Journal").Range("B3").Name = "PayrollB3"
This will allow you to get rid of a lot of the fluff.
Sub Extract_Bank_Amount2()
Dim cell As Range
With Worksheets("Bank Statement")
For Each cell In .Range("B" & .Rows.Count).End(xlUp)
If cell.Offset(0, -1).Value = Range("PayrollB1").Value Then
If cell.Offset(0, 1).Value = Range("PayrollB3").Value Then
With wb.Sheets("Proof")
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Value = cell.Value
End With
End If
End If
Next
End With
End Sub
You should also download Rubberduck. Rubberduck is a COM add-in for the VBA IDE that will help you debug and optimise your code. Most importantly for me it saves me a ton of time by formatting my code for me.
I have what is working code but I want to be able to run it 2,3, 4 times and have it just keep moving down the destination sheet. Instead it overwrites what the last pass pasted.
Sub Comparison_Entry()
Dim myWord$
myWord = InputBox("Enter UID, If no more UIDs, enter nothing and click OK", "Enter User")
If myWord = "" Then Exit Sub
Application.ScreenUpdating = False
Dim xRow&, NextRow&, LastRow&
NextRow = 1
LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For xRow = 1 To LastRow
If WorksheetFunction.CountIf(Rows(xRow), "*" & myWord & "*") > 0 Then
Rows(xRow).Copy Sheets("Sheet1").Rows(NextRow)
NextRow = NextRow + 1
End If
Next xRow
Application.ScreenUpdating = True
MsgBox "Copyng complete, " & NextRow - 2 & " rows containing" & vbCrLf & _
"''" & myWord & "''" & " were copied to Sheet1.", 64, "Done"
End Sub``
I tried adding a loop to this but each pass through it would start over at the top of Sheet1. Similarly, if I simply call the Sub again I get the same result.
Normally you would know what column to search through, such as what column is UID. in this example code I will assume it is column A of the active sheet, change the column letter to what suites you.
Sub Comparison_EntryB()
Dim Rws As Long, rng As Range, c As Range
Dim ws As Worksheet, sh As Worksheet, s As String
Set ws = ActiveSheet
Set sh = Sheets("Sheet1")
With ws
Rws = .Cells(.Rows.Count, "A").End(xlUp).Row 'change to column you need you search through
Set rng = .Range(.Cells(1, "A"), .Cells(Rws, "A")) 'change to column you need to search through
End With
s = InputBox("enter Something")
For Each c In rng.Cells
If UCase(c) Like "*" & UCase(s) & "*" Then
c.EntireRow.Copy sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next c
End Sub