I have some code where I am using index(match) based on a cell with a dropdown menu. When users select a certain security, a CUSIP is outputted which then pastes formulas from bloomberg to output the data into excel.
I then proceed to create a table but would like to filter the table using autofilter and delete the rows that dont meet the filter criteria but that doesnt seem to be working for some reason! I also have insrted an activex control form button so that when a user double clicks on the dropdown menu they can search for a security and it would autocomplete.
Please help, Thanks!
Sub INDEX_MATCH_CUSIP_TO_SHORTDESCRIPTION()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Sheet4").Range("B3:E100").Delete
Range("B2").Select
test = Application.WorksheetFunction.Index(Sheets("DEX Spread Report (Corp)").Range("B7:B1600"), Application.WorksheetFunction.Match(ActiveCell.Value, Sheets("DEX Spread Report (Corp)").Range("D7:D1600"), 0), 1)
ActiveCell.Offset(1, 0).Value = test
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub BBRG_FORMULAS_FOR_SECURITY()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim CUSIPS As String
Sheets("Sheet4").Select
Range("B2").Select
CUSIPS = ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(2, 0).Value = "=BDS(""" & CUSIPS & """ & ""& CUSIP"",""ALL_HOLDERS_PUBLIC_FILINGS"", ""STARTCOL=1"", ""ENDCOL=1"")"
ActiveCell.Offset(2, 1).Value = "=BDS(""" & CUSIPS & """ & ""& CUSIP"",""ALL_HOLDERS_PUBLIC_FILINGS"", ""STARTCOL=6"", ""ENDCOL=8"")"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Create_Table_and_AutoFilter()
Dim wksDest As Worksheet
Dim LastRow As Long
Dim rng As Range
Dim rngDelete As Range
Sheets("Sheet4").Select
Set wksDest = Worksheets("Sheet4")
LastRow = Cells(Rows.Count, 2).End(xlUp).row
LastRow1 = Cells(Rows.Count, 2).End(xlUp).row
ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(4, 2), Cells(LastRow, 5)), , xlYes).Name = "HoldersTable"
With wksDest
Set rng = Range(Cells(4, 2), Cells(LastRow1, 5))
rng.AutoFilter Field:=1, Criteria1:="<=1000"
Set rngDelete = rng.SpecialCells(xlCellTypeVisible)
rng.AutoFilter
rngDelete.EntireRow.Delete
End With
End Sub
you're most probably trying to delete table header
try substituting the code from With wksDestto End With with the following snippet:
With wksDest.Range(Cells(4, 2), Cells(LastRow1, 5))
.AutoFilter Field:=1, Criteria1:="<=1000"
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(,1)) > 1 Then .offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
Related
I'm working on a macro that will search a List sheet for different counties and then paste the entire row onto the current sheet. I have a worksheet for each person (named Mark, John, etc.) and each person is assigned several counties. Mark has three counties, listed in cells J1:L1, which I've named as a range (MyCounties). I need a macro that will look through Sheet "List" column "I" for each of those counties and copy the entire row onto Sheet "Mark" starting at "A4". I'm using a modified macro I found on here, but I must be doing something wrong. It is currently giving me an error "Application defined or object defined error" in regards to Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))
Sub NewSheetData()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim Rng As Range, rCell As Range
Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))
For Each rCell In Range("MyCounties")
On Error Resume Next
With Rng
.AutoFilter , field:=1, Criteria1:=rCell.Value
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
.AutoFilter
End With
On Error GoTo 0
Next rCell
Application.EnableEvents = True
End Sub
This code will need to be adjusted to accommodate your named ranges and worksheet names. It currently uses named ranges with worksheet scope from each worksheet.
Sub NewSheetData()
Dim w As Long, sWSs As Variant, vCrit As Variant, rw As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
sWSs = Array("Mark", "John", "etc")
For w = LBound(sWSs) To UBound(sWSs)
With Worksheets(sWSs(w))
vCrit = .Range("MyCounties").Value2
rw = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 4)
End With
With Worksheets("List")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(4, "I"), .Cells(.Rows.Count, "I").End(xlUp))
.AutoFilter field:=1, Criteria1:=vCrit, Operator:=xlFilterValues
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Cells)) Then
.Cells.EntireRow.Copy Destination:=Worksheets(sWSs(w)).Cells(rw, "A")
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
Next w
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
This uses the values from each worksheet's MyCounties named range as an array of criteria for .AutoFilter. using an array as criteria requires the Operator:=xlFilterValues parameter. It also checks to make sure that there are filtered values to copy before copying them.
may be your EntireRow is copying rows whose first column is blank
you could use UsedRange property of worksheet object to get the last used row
furthermore you'd better place With Rng oustide the loop, since it doesn't change with it
Option Explicit
Sub NewSheetData()
Dim Rng As Range, rCell As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Sheets("List")
Set Rng = .Range("I4", .Range("I" & .Rows.Count).End(xlUp))
End With
With Rng
For Each rCell In Range("MyCounties")
.AutoFilter , Field:=1, Criteria1:=rCell.Value
If Application.WorksheetFunction.Subtotal(103, .cells) > 1 Then .Resize(.Rows.Count - 1).Offset(1).EntireRow.Copy _
Sheets("Sheeta2").Range("A" & Sheets("Sheeta2").UsedRange.Rows(Sheets("Sheeta2").UsedRange.Rows.Count).Row).Offset(1)
Next
.Parent.AutoFilterMode = False
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I known, this question has been asked thousands of times. But every time I picked up a solution appears error when i debug. (error 1004)
I work with a database with about 300000 lines, where more than half do not care. (I know that have filter, but wanted to erase to reduce the file and speed up the process).
Then if the column M has a keyword like "water", "beer" or "vodka" it will delete the row. I mean, don't need to be the exact word, just the keyword.
OBS: Row 1 it's a table title with the frozen line.
Thanks!
The following code works less than 4 seconds for processing your sample data on my machine:
Sub QuickDeleteRows()
Dim Sheet_Data As Worksheet, NewSheet_Data As Worksheet, Data As Range
Dim Sheet_Name As String, Text As String, Water As Long, Beer As Long, Vodka As Long
On Error GoTo Error_Handler
SpeedUp True
Set Sheet_Data = Sheets("SOVI")
Sheet_Name = Sheet_Data.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Output(1 To LastRow - 1, 1 To 1) As Long
For i = 1 To LastRow - 1
Text = Cells(i + 1, 13)
Water = InStr(Text, "water")
Beer = InStr(Text, "beer")
Vodka = InStr(Text, "vodka")
If Water > 0 Or Beer > 0 Or Vodka > 0 Then Output(i, 1) = 1
Next
[S2].Resize(LastRow - 1, 1) = Output
LastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
Set Data = Sheet_Data.Range(Cells(1, 1), Cells(LastRow, LastColumn))
Set NewSheet_Data = Sheets.Add(After:=Sheet_Data)
Data.AutoFilter Field:=19, Criteria1:="=1"
Data.Copy
With NewSheet_Data.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
.Cells(1, 1).Select
.Cells(1, 1).Copy
End With
Sheet_Data.Delete
NewSheet_Data.Name = Sheet_Name
NewSheet_Data.Columns(19).Clear
Safe_Exit:
SpeedUp False
Exit Sub
Error_Handler:
Resume Safe_Exit
End Sub
Sub SpeedUp(SpeedUpOn As Boolean)
With Application
If SpeedUpOn Then
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayStatusBar = False
.DisplayAlerts = False
Else
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.DisplayAlerts = True
End If
End With
End Sub
In the future, please post code you've tried first for the community to help you out. That being said, try this out:
Sub Test()
Dim x as Long
Dim i as Long
x = Sheets("SOVI").Range("M" & Rows.Count).End(xlUp).Row
For i = x to 2 Step -1
If InStr(1, Range("M" & i).Value, "water", vbTextCompare) Or InStr(1, Range("M" & i).Value, "beer", vbTextCompare) Or InStr(1, Range("M" & i).Value, "vodka", vbTextCompare) Then
Range("M" & i).entirerow.delete
End If
Next i
End Sub
I would use a slightly different approach, with the Like and with Select Case - this will give you more versatility in the future if you would want to expand it to more types of drinks.
Sub FindDrink()
Dim lRow As Long
Dim i As Long
Dim sht As Worksheet
' always set your sht, modify to your sheet name
Set sht = ThisWorkbook.Sheets("Sheet1")
lRow = sht.Cells(sht.Rows.Count, "M").End(xlUp).Row
For i = lRow To 2 Step -1
Select Case True
Case (sht.Cells(i, "M").Value Like "*beer*") Or (sht.Cells(i, "M").Value Like "*water*") Or (sht.Cells(i, "M").Value Like "*vodka*")
Range("M" & i).EntireRow.Delete
Case Else
' if you decide to do other things in the future for other values
End Select
Next i
End Sub
use excel built in filtering functions for the maximum speed
Autofilter
Option Explicit
Sub main()
Dim keysToErase As Variant, key As Variant
keysToErase = Array("water", "beer", "vodka") '<--| list your keywords to delete matching column "M" rows with
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
For Each key In keysToErase '<--| loop through keys
.AutoFilter field:=13, Criteria1:="*" & key & "*" '<--| filter column "M" with key
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
Next key
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
AdvancedFilter
Option Explicit
Sub main2()
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Parent.Range("U1:U4") '<--| this filters on all keys you placed in cells "U2:U4" with cell "U1" with wanted data header
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
Try with Below code
Sub test()
Application.DisplayAlerts = False
Dim lastrow As Long
Dim i As Long
Dim currentrng As Range
lastrow = Range("M" & Rows.Count).End(xlUp).Row
For i = lastrow To 2 Step -1
Set currentrng = Range("M" & i)
If ((currentrng Like "*water*") Or (currentrng Like "*beer*") Or (currentrng Like "*vodka*")) Then
currentrng.EntireRow.Delete shift:=xlUp
End If
Next i
Application.DisplayAlerts = True
End Sub
I have written the below script to copy a range of data from one sheet to another workbook based on a set of criteria. I now need to add an extra piece to filter this acceptable data to different sheets named after the values in column G and if the value doesn't already exist to create the sheet named after the value. For example if column G value = JULA then to copy this to sheet JULA however if this doesn't already exist then to create and copy.
Private Sub cmdArchive_click()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim LastRow As Integer, i As Integer, erow As Integer
iForm = ("\\Insurance\It\FileData\Computers\Release Note\Collated Release Records\Master.xlsx")
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To LastRow
If Cells(i, 1) <> "" And Cells(i, 9) = "" And Cells(i, 9) = "" Then
Range(Cells(i, 1), Cells(i, 4)).Select
Selection.Copy
workbooks.Open Filename:=iForm
Worksheets("Scheduled Forms").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
MsgBox ("iForms have been archived, please clear the Team Release notes ready for the next implimentation window"), vbInformation + vbOKOnly, "Complete!"
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Thank you in advance.
I need to remove all rows without leaving any unique record. If duplicate exists delete all matching rows. Criteria is column C if any duplicate record exists in column C then delete entire row (including unique).
Below given code is working but leaving the unique row Even I don't want that.
Code:
Sub DDup()
Sheets("MobileRecords").Activate
With ActiveSheet
Set Rng = Range("A1", Range("C1").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(3, 3), Header:=xlYes
End With
End Sub
I like the code from Jeeped, but it isn't the best readable one. Therefore, here is another solution.
Sub remDup()
Dim rng As Range, dupRng As Range, lastrow As Long, ws As Worksheet
Dim col As Long, offset As Long, found As Boolean
'Disable all the stuff that is slowing down
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Define your worksheet here
Set ws = Worksheets(1)
'Define your column and row offset here
col = 3
offset = 0
'Find first empty row
Set rng = ws.Cells(offset + 1, col)
lastrow = rng.EntireColumn.Find( _
What:="", After:=ws.Cells(offset + 1, col)).Row - 1
'Loop through list
While (rng.Row < lastrow)
Do
Set dupRng = ws.Range(ws.Cells(rng.Row + 1, col), ws.Cells(lastrow, col)).Find( _
What:=rng, LookAt:=xlWhole)
If (Not (dupRng Is Nothing)) Then
dupRng.EntireRow.Delete
lastrow = lastrow - 1
found = True
If (lastrow = rng.Row) Then Exit Do
Else
Exit Do
End If
Loop
Set rng = rng.offset(1, 0)
'Delete current row
If (found) Then
rng.offset(-1, 0).EntireRow.Delete
lastrow = lastrow - 1
End If
found = False
Wend
'Enable stuff again
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
It works with more than one duplicate and you can define an row offset, which defines how much rows you ignore at the beginning of the column.
I like to try these without any declared variables. It is good practise for keeping your cell / worksheet / workbook hierarchy together.
Sub dupeNuke()
With Worksheets("Sheet1") '<~~ you should know what worksheet you are supposed to be on
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, 1).Offset(1, 2)
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=COUNTIF(C:C, C2)>1"
End With
With .FormatConditions(.FormatConditions.Count)
.Interior.Color = vbRed
End With
End With
With .Resize(.Rows.Count, 1).Offset(0, 2)
.AutoFilter Field:=1, Criteria1:=vbRed, Operator:=xlFilterCellColor
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, Cells)) Then
.EntireRow.Delete
End If
End With
End With
With .Resize(.Rows.Count - 1, 1).Offset(1, 2)
With .FormatConditions
.Delete
End With
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
Obviously, this is heavily reliant on the With ... End With statement. An underrated / underused method in my estimation.
I found this code, it was only for one column to find all unique values, and filter them,copy/paste in filtered values named sheet.
But what I need to do, is filter two columns, and name it by the same principles, so I modified it.
Somehow on second value in first loop, it doesnt start loop in other loop.
Why does it give me blanks in second loop?
Sub datu_sagrupesana()
Dim x As Range, y As Range, rng As Range, last As Long, sht As Worksheet
Application.ScreenUpdating = False
'datu vieta
Set sht = ThisWorkbook.Worksheets("Test")
'apgabals
last = sht.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = sht.Range("A1:C" & last)
sht.Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True 'produkta filtrs
sht.Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True 'valodas filtrs
For Each y In Range([J2], Cells(Rows.Count, "J").End(xlUp))
For Each x In Range([H2], Cells(Rows.Count, "H").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=y.Value
.AutoFilter Field:=1, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = y.Value & x.Value
ActiveSheet.Paste
End With
Next x
Next y
'nonemt filtru
sht.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
SOLVED by myself
Sub datu_sagrupesana()
Dim x As Long, y As Range, rng As Range, last As Long, sht As Worksheet
Application.ScreenUpdating = False
'datu vieta
Set sht = ThisWorkbook.Worksheets("Test")
'apgabals
last = sht.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = sht.Range("A1:C" & last)
sht.Range("A1:A" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True 'produkta filtrs
sht.Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("I1"), Unique:=True 'valodas filtrs
pr = Application.WorksheetFunction.CountA(sht.Columns("H"))
va = Application.WorksheetFunction.CountA(sht.Columns("I"))
For j = 2 To va
For i = 2 To pr
valoda = sht.Cells(j, "I").Value
produkts = sht.Cells(i, "H").Value
'
'For Each y In Range("J2", Cells(Rows.Count, "J").End(xlUp))
'
'
'For Each x In Range("H2", Cells(Rows.Count, "H").End(xlUp))
'
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=valoda
.AutoFilter Field:=1, Criteria1:=produkts
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = valoda & produkts
ActiveSheet.Paste
End With
'
'Next x
'Next y
Next i
Next j
'nonemt filtru
sht.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub