I am a military recruiter and am trying to use autofilter to filter out a range from another range. I got this from another stackoverflow page but can not figure out how to change that string strSearch to a range like 123#gmail, 234#gmail, 345#gmail, etc.
We get lists of leads but I'd like to keep the running list of opt-outs and have VBA double check and delete any cells that have a value from the opt-out worksheet. I am pretty new to VBA but really enjoy it. Thank you!
I'd like it to be strSearch = Sheets("Opt-Outs").Range("A:A") so that it takes all values in A:A and uses them as an autofilter. I believe it needs to be a string array but am lost as how to get there. Please help.
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub
This should do it...
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
Dim v() As Variant
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
v = Application.Transpose(Sheets("Opt-Outs").Range("A:A"))
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:=v
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As Variant
Dim i As Integer
i = 1
Sheets("Opt-Outs").Select
Range("H2").Value = "Ready"
Range("A2").Select
Do While Range("H2").Value <> Empty
Sheets("Opt-Outs").Select
Range("A2").Select
Cells(i + 1, 1).Copy
i = i + 1
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Range("H2").Value = IsBlank Then
Sheets("Email Addresses").Select
Exit Sub
Else
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("H2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End If
Loop
Related
This is my first time asking a question on here. I have dug through similar questions, but have had no luck yet in resolving this quandary. I appreciate any help you can give me.
In the data set I am working with, I am looking to delete any rows that contain the word "Bench" in column R. I already have the rest of the worksheet running and have the Lrow value set as the last row.
I was first successful using the .Setfilter, selecting the range, and using EntireRow.Delete. But this ended up deleting the entire dataset if there were no rows to select.
To summarize the ask: Looking in Range("R2":"R" & Lrow), find all cells containing the text "Bench", then Delete the row.
Thank you!
Here is the entire VBA as sits right now (this bit is near the bottom):
Sub BE_Time_to_Fill()
'
' BE_Time_to_Fill Macro
'
Dim StartCell As Range
Dim RangeName As String
Dim myValue As Variant
Set StartCell = Range("A1")
myValue = InputBox("Enter Date: YY-MMM")
'Select Range
StartCell.CurrentRegion.Select
RangeName = "Dataset"
Dim LRow As Long
Dim lCol As Long
'Find the last non-blank cell in column A(1)
LRow = Cells(Rows.Count, 1).End(xlUp).Row
'Find the last non-blank cell in row 1
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns("J:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("J1").FormulaR1C1 = "Time to Fill"
Range("J2", "J" & LRow).FormulaR1C1 = "=RC[1]+RC[2]"
Range("F1").Select
Range("F1").FormulaR1C1 = "Job Code"
Range("F1", "F" & LRow).AutoFilter 1, ""
Range("F2", "F" & LRow).FormulaR1C1 = "=RC[-1]"
[F1].AutoFilter
Range("M1").FormulaR1C1 = "Source Time"
Columns("N:N").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("N1").FormulaR1C1 = "Cycle Time"
Range("N2", "N" & LRow).FormulaR1C1 = "=IMSUB(RC[1],RC[-1])"
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").FormulaR1C1 = "Application ID"
Range("A2", "A" & LRow).FormulaR1C1 = "=CONCATENATE(RC[1],RC[4])"
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").FormulaR1C1 = "Timeframe"
Range("B2", "B" & LRow).Value = myValue
Dim rng As Range
Dim DelRng As Range
Set DelRng = Range("R2:R" & LRow)
For Each rng In DelRng
If rng.Value = "*Bench" Then
rng.EntireRow.Delete
ElseIf rng.Value <> "*Bench" Then
End If
Next
Range("G:H,M:N").Delete Shift:=xlToLeft
Range("A1").Select
End Sub
Without seeing what code you have we can't help update it. But from your question the below might help.
If you're using a loop you'll need to include what to do if the set conditions aren't met. See example:
Sub example()
Dim rng As Range, DelRng As Range
Dim LastRow As Long
LRow = Range("R" & Rows.Count).End(xlUp).Row 'test for last filled row in column R
Set DelRng = Range("R1:R" & LRow) 'sets your range
For Each rng In DelRng
'change this value to match whatever you want to find. make sure this is entered as ALL CAPS and without spaces
If UCase(WorksheetFunction.Substitute(rng.Value, " ", "")) = "GEM/BENCH" Then
rng.EntireRow.Delete
ElseIf UCase(WorksheetFunction.Substitute(rng.Value, " ", "")) <> "GEM/BENCH" Then 'if loop can't find anything it will just exit
End If
Next
End Sub
for the code below, if a search comes up empty based on Criteria1:="Ship", then there is nothing to copy, and the code stops at Set rngCopy = Intersect(rngCopy, .Range("A1:H" & lRow), .Range("A1:H" & lRow).Offset(1)).SpecialCells(xlCellTypeVisible), how can I get rid of this bug? Additionally, I want the whole table to show even if no data meets the criteria. I have the line Worksheets("Efficiency").ShowAllData but this is under the assumption the code runs all the way.
Thanks,
Sub ImportShipper()
Dim wsEff As Worksheet
Dim wsShip As Worksheet
Dim wsFirst As Worksheet
Set wsEff = Worksheets("Efficiency")
Set wsFirst = Worksheets("1")
Set wsShip = ActiveSheet
wsShip.Name = wsFirst.Range("B34").Value
With wsEff
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:H" & lRow).AutoFilter Field:=2, Criteria1:="Ship"
Dim rngCopy As Range
'All Columns A:H
Set rngCopy = .Columns("A:H")
'filtered rows, not including header row - assumes row 1 is headers
Set rngCopy = Intersect(rngCopy, .Range("A1:H" & lRow), .Range("A1:H" & lRow).Offset(1)).SpecialCells(xlCellTypeVisible)
rngCopy.Copy
End With
wsShip.Range("A4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Efficiency").ShowAllData
End Sub
you could go like this
Option Explicit
Sub ImportShipper()
Dim wsEff As Worksheet
Dim wsShip As Worksheet
Dim wsFirst As Worksheet
Set wsEff = Worksheets("Efficiency")
Set wsFirst = Worksheets("1")
Set wsShip = ActiveSheet
wsShip.Name = wsFirst.Range("B34").value
With wsEff
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:H" & lRow)
.AutoFilter Field:=2, Criteria1:="Ship"
With .Offset(1).Resize(.Rows.Count - 1)
If Application.WorksheetFunction.Subtotal(103, .Columns(2)) > 0 Then
.SpecialCells(xlCellTypeVisible).Copy
wsShip.Range("A4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End With
End With
End With
Worksheets("Efficiency").ShowAllData
End Sub
I want to copy row(A:E), row(F:AH), and row(AL)from the active workbook to row(A:E), row(G:AI), row(AJ) of another workbook. Here's the code that I'm working on. I saw it here and just edited it.
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim strSearch As String
Dim ret
ret = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls, .xlsx*),*.xls, .xlsx*", _
Title:="Select data file for Monitoring Log")
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Macro Template")
strSearch = "Newly Distributed"
With ws1
.AutoFilterMode = False
lRow = .Range("AL" & .Rows.Count).End(xlUp).Row
With .Range("AL7:AL" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Destination File
Set wb2 = Application.Workbooks.Open(ret)
Set ws2 = wb2.Worksheets("Source")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
Else
lRow = 1
End If
copyFrom.Copy .Rows(lRow)
End With
wb2.Save
wb2.Close
This code copies the entire row. How can I revise it to copy specific rows.
Replace
copyFrom.Copy .Rows(lRow)
with
copyFrom.Columns("A:E").Copy .Cells(lRow, "A")
copyFrom.Columns("F:AH").Copy .Cells(lRow, "G")
copyFrom.Columns("AL").Copy .Cells(lRow, "AJ")
From the source code, i just could see you copy the data from the column AL to another worksheet.
I modified your code and it successfully copy to the another worksheet. The copy function could be written in 1 line instead of multiple line.
Option Explicit
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lRow As Long
Dim lRow2 As Long
Dim strSearch As String
Sub Test()
Dim ret
ret = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls, .xlsx*),*.xls, .xlsx*", _
Title:="Select data file for Monitoring Log")
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Macro Template")
strSearch = "Newly Distributed"
With ws1
.AutoFilterMode = False
lRow = .Cells(Rows.Count, "AL").End(xlUp).Row
'lRow = .Range("AL" & .Rows.Count).End(xlUp).Row
With .Range("AL7:AL" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
End With
End With
'~~> Destination File
Set wb2 = Application.Workbooks.Open(ret)
Set ws2 = wb2.Worksheets("Source")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow2 = .Cells(Rows.Count, "A").End(xlUp).Row
Else
lRow2 = 1
End If
'copyFrom.Copy .Rows(lRow)
ws1.Range("AL8:AL" & lRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ws2.Range("A" & lRow2)
End With
'~~> Remove any filters
ws1.AutoFilterMode = False
wb2.Save
wb2.Close
End Sub
I have the following Code and I would like it to run in 25 other sheets of the Workbook and instead of repeating the code 25 times,for each sheet is there a way to make it loop?
Can someone assist?
Sub DeleteEmptyRows()
Dim ws As Worksheet
Dim strSearch As String
Dim lRow As Long
strSearch = "ressort"
Set ws = Sheets("01,02,03")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ActiveSheet.Range("$A$1:$P$65536").AutoFilter Field:=1
End With
End Sub
Wrap the processing code in a loop
for each ws in thisworkbook.sheets
' do something on each worksheet
next
example
Sub DeleteEmptyRows()
Dim ws As Worksheet
Dim strSearch As String
Dim lRow As Long
strSearch = "ressort"
For Each ws In ThisWorkbook.Sheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Sheet2") And (ws.Name <> "Sheet3") Then
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.Range("$A$1:$P$65536").AutoFilter Field:=1
End With
End If
Next
End Sub
so now if the sheet names are Sheet1 or Sheet2 or Sheet3 they will be skipped.
Your code will need to be stored in a module, rather than being contained in a sheet. The following illusrates how the loop works:
Sub test()
Dim thisSheet As Worksheet
For Each sheet In Sheets
thisSheet.Cells(1, 1) = 1
Next
End Sub
I am writing a macro that creates variable worksheets based on a value on an existing worksheet. I managed that part fine, but now I need to add a VLOOKUP formula on another sheet that references the newly created sheets. There is no set pattern to the name of the new worksheets, so I having trouble referencing them. Here is the code I used to create the new worksheets:
Dim ws As Worksheet
Dim rngCriteria As Range
Dim sName As String
Dim I As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("Part Type REC")
If .AutoFilterMode = True Then .AutoFilterMode = False
.Range("D1:D" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("J1"), Unique:=True
Set rngCriteria = .Range("J1").CurrentRegion
For I = 2 To .Cells(Rows.Count, "J").End(xlUp).Row
sName = .Cells(I, "J")
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = sName
.Range("D1:D" & LastRow).AutoFilter Field:=1, Criteria1:="=" & .Cells(I, "J").Value
.Range("A1:H" & LastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range("A1")
Next I
.AutoFilterMode = False
End With
Sheets("Part Type REC").Select
Columns("J:J").Select
Selection.ClearContents
Range("A1").Select
And here is the VLOOKUP that I need to reference the new worksheets:
Sheets("TP Parts").Select
Range("O2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],'ws.name'!C[-14],1,FALSE)"
Range("O2").Select
Where am I going wrong with this?
Thanks in advance!
Try this (UNTESTED - Just typed it here)
Range("O2").FormulaR1C1 = "=VLOOKUP(RC[-1]," & ws.name & "!C[-14],1,FALSE)"