If my chart data only equals to one column it gives an error.
Sub RemoveHiddenColumns()
Dim myChart As Chart
Set myChart = Chart4
myChart.Activate 'first activate the chart
Dim i As Integer
For i = 1 To ActiveChart.SeriesCollection.Count 'loop through each series
Dim strText As String, strCol As String, strSht As String, intCol As Integer
strText = Split(ActiveChart.SeriesCollection(i).Formula, ",")(2) 'extract sheet name and column of series
strSht = Split(strText, "!")(0)
strCol = Split(strText, "!")(1) 'get column range of series
Dim wks As Worksheet
Set wks = Sheet2
If wks.Range(strCol).EntireColumn.Hidden = True Then 'if the column is hidden
ActiveChart.SeriesCollection(i).Delete 'remove the series
End If
Next
End Sub
This code successfully removes hidden ROWS from a table. I know that you want to remove columns, but I'm not sure entirely what you're going for so I didn't try and adapt it. You should be able to do that fairly easily.
Sub RhidRow2(ByVal count4 As Long)
Dim count1 As Long 'counters to be used
Dim ws As Worksheet
Dim rngVis As Range
Dim rngDel As Range
Set ws = ActiveSheet
On Error Resume Next
Set rngVis = ws.Range("A2:A" & count4).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rngVis Is Nothing Then
ws.Range("Z1").Value = 1
Else
For count1 = count4 To 2 Step -1
If ws.Rows(count1).Hidden = True Then
If rngDel Is Nothing Then
Set rngDel = ws.Rows(count1)
Else
Set rngDel = Union(rngDel, ws.Rows(count1))
End If
End If
Next count1
If Not rngDel Is Nothing Then
Application.DisplayAlerts = False
Intersect(rngDel, rngDel.ListObject.DataBodyRange).Delete 'if row is hidden, delete
Application.DisplayAlerts = True
End If
End If
End Sub
Related
Im trying to copy a table range with criteria, however I am not able to define the criteria to copy the desired lines, which consists of copying only the lines where the CC column has data skiping the entire row if CC is empty. I'll just copy ( copy to clipboard ), for paste I'll do it manually for other reasons
The lines will always be like this, never with a whole blank line between them like the second image
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For Each rng In .Range("B3:I3" & bottomA)
If WorksheetFunction.Sum(.Range("B" & rng.Row & ":I" & rng.Row)) > 0 Then
Range("B" & rng.Row & ":I" & rng.Row)).Copy
End If
Next rng
End With
Application.ScreenUpdating = True
End Sub
Use Union to select a non-contiguous range.
Option Explicit
Sub CopyValues()
Dim wb As Workbook, ws As Worksheet
Dim rng As Range, rngB As Range
Dim tbl As ListObject
Set wb = ThisWorkbook
Set ws = wb.Sheets("CC2")
With ws.ListObjects("Tabela452")
For Each rngB In .ListColumns("CC").DataBodyRange
If Len(rngB) > 0 Then
If rng Is Nothing Then
Set rng = rngB.Resize(1, 8) ' B to I
Else
Set rng = Union(rng, rngB.Resize(1, 8))
End If
End If
Next
End With
If rng Is Nothing Then
MsgBox "Nothing selected", vbExclamation
Else
rng.Select
rng.Copy
MsgBox "range copied " & rng.Address, vbInformation
End If
End Sub
Please, test the next adapted code. It does not need any iteration:
Sub CopyValues()
Dim rngCopy As Range, tbl As ListObject
Dim srcWS As Worksheet: Set srcWS = Sheets("CC2")
Set tbl = srcWS.ListObjects(1) 'use here the table name, if more than 1
On Error Resume Next 'for the case of no any value in the table first column
Set rngCopy = tbl.DataBodyRange.Columns(1).SpecialCells(xlCellTypeConstants)
'or
'Set rngCopy = tbl.DataBodyRange.Columns(tbl.ListColumns("CC").Index).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngCopy Is Nothing Then 'for the case of no any values in table first column
Intersect(rngCopy.EntireRow, tbl.DataBodyRange).Copy
Else
MsgBox "No any value in column ""CC""..."
End If
End Sub
As I said in my comment, it works if the values in column "CC" are not result of formulas...
Copy Filtered Rows From Excel Table (ListObject)
The screenshot illustrates the benefits of using an Excel table:
The table can be anywhere on the worksheet.
You can easily reference a column by its name (header).
You can move the column anywhere in the table.
Sub CopyFilteredRows()
' Define constants.
Const WorksheetName As String = "CC2"
Const TableName As String = "Tabela452"
Const CriteriaColumnName As String = "CC"
Const Criteria As String = "<>" ' non-blanks ('blank' includes 'empty')
' Reference the objects ('wb', 'ws' , 'tbl', 'lc')
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(TableName)
Dim lc As ListColumn: Set lc = tbl.ListColumns(CriteriaColumnName)
' Reference the filtered rows ('rrg').
Dim rrg As Range
With tbl
If .ShowAutoFilter Then ' autofilter arrows are turned on
' Clear all filters.
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
Else ' autofilter arrows are turned off
.ShowAutoFilter = True ' turn on the autofilter arrows
End If
.Range.AutoFilter lc.Index, Criteria
' Attempt to reference the filtered rows ('rrg').
On Error Resume Next
' Reference the visible cells.
Set rrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
' When columns are hidden, resize to entire rows of the table.
Set rrg = Intersect(.DataBodyRange, rrg.EntireRow)
On Error GoTo 0
' Clear the filter.
.AutoFilter.ShowAllData
End With
' Invalidate the filtered rows.
If rrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
' Copy.
rrg.Copy
End Sub
For the criteria when looking for empty values, you can always use LEN to check the number of characters in the cell.
If it is greater than 0 it means that something is in there, you can also set it to an exact amount of digits to be more precise.
Something like this should work:
Sub CopyValues()
Application.ScreenUpdating = False
Dim rng As Range
Dim bottomA As Long
Dim srcWS As Worksheet
Dim currentRow As Long
Const ccColumn As Long = 2
Const startingRow As Long = 3
Set srcWS = Sheets("CC2")
With srcWS
bottomA = .Range("B" & .Rows.Count).End(xlUp).Row
For currentRow = startingRow To bottomA
If Len(.Cells(currentRow, ccColumn).Value) > 0 Then
.Range("B" & currentRow & ":I" & currentRow).Copy
End If
Next currentRow
End With
Application.ScreenUpdating = True
End Sub
The below code thanks to #FaneDuru helped me copying filtered data to a new sheet, what I need to tweak is copying each set of data with a separate header instead of one main header for all data and also cut data instead of copy
Code:
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the uneque Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) + 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF Is Nothing Then
rngF.Copy wsComp.Range("A1")
End If
ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
What I want data to look like (separate data by header)
[![enter image description here][1]][1]
Link to Faneduru profile: https://stackoverflow.com/users/2233308/faneduru
If I can't cut and paste data, I used the below code to filter for the copied data to new sheets and delete it by using the "Or formula" and filtered for True and deleted those rows as the filter only takes 2 criteria.
Sub Delete()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
lastRow = ActiveSheet.Range("B1").Rows.End(xlDown).Row
Set rng = ws.Range("A1:AD" & lastRow)
ActiveSheet.Range("AD1").Value = "TRUE/FALSE"
ActiveSheet.Range("AD2").Formula = "=OR(D2=""108169651"",D2=""108169430"",D2=""108168704"",D2=""108169596"")"
ActiveSheet.Range("AD2:AD" & lastRow).Formula = ActiveSheet.Range("AD2").Formula
With rng
.AutoFilter Field:=30, Criteria1:="True"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
' turn off the filters
ws.AutoFilterMode = False
End Sub
I added the call sub for the above code at the end of your (CopyFilteredCustomersByCompanyNames) Sub:
Option Explicit
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
'Array of Distributors which we need to add in new sheets
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
'Clear all Filters if any
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the unique Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) + 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range, rngF1 As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF1 = Nothing
Set rngF1 = rngFilt.Resize(rngFilt.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible):
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF1 Is Nothing Then
rngF.Copy wsComp.Range("A1")
InsertHeaders wsComp
Else
Application.DisplayAlerts = False
wb.Worksheets(keyC).Delete
Application.DisplayAlerts = True
End If
'ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
ws.AutoFilterMode = False
'MsgBox "Ready..."
Delete
End Sub
IS that correct or do you have any other recommendations
Please, copy the next solution to a standard module (instead of the existing code):
Option Explicit
Sub CopyFilteredCustomersByCompanyNames()
Dim wb As Workbook, ws As Worksheet, lastR As Long, wsComp As Worksheet, dictC As Object
Dim rngFilt As Range, arrCust() As Variant, arrFilt, i As Long
arrCust = Array("108169651", "108169651", "108169430", "108169430", "108168704", "108169596") 'place here the 10 specific customers name
Set wb = ActiveWorkbook 'use here the workbook you need
Set ws = ActiveSheet 'use here the necessary sheet (the one to be processed)
If ws.FilterMode Then ws.ShowAllData
Set rngFilt = ws.Range("A1").CurrentRegion: ' Debug.Print rngFilt.Address: Stop
arrFilt = rngFilt.Value2 'place the range in an array for faster iteration
'extract the uneque Company Names:
Set dictC = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrFilt)
If arrFilt(i, 1) <> "" Then
dictC(arrFilt(i, 1)) = dictC(arrFilt(i, 1)) + 1
End If
Next i
Application.ScreenUpdating = False 'optimization to make code faster
Dim keyC As Variant, rngF As Range, rngF1 As Range
For Each keyC In dictC.Keys 'iterate between dictionary keys (A:A company names)
rngFilt.AutoFilter 1, keyC 'first filter by dict key
rngFilt.AutoFilter 4, arrCust, xlFilterValues 'second by array of customers numbers
Set wsComp = Nothing
'insert the necessary sheets, name them (if not existing), clear if existing and copy the filtered range
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
Set wsComp = wb.Worksheets(keyC)
On Error GoTo 0
If Not wsComp Is Nothing Then
wsComp.Cells.ClearContents
Else
Set wsComp = wb.Worksheets.Add(After:=ws)
wsComp.Name = keyC
End If
rngFilt.Rows(1).Copy ' copy the headers columns width
wsComp.Range("A1").Resize(, rngFilt.Rows(1).Columns.Count).PasteSpecial xlPasteColumnWidths
On Error Resume Next
Set rngF1 = Nothing
Set rngF1 = rngFilt.Resize(rngFilt.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible):
Set rngF = rngFilt.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngF1 Is Nothing Then
rngF.Copy wsComp.Range("A1")
InsertHeaders wsComp
Else
Application.DisplayAlerts = False
wb.Worksheets(keyC).Delete
Application.DisplayAlerts = True
End If
ws.ShowAllData
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Next keyC
Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Sub InsertHeaders(ws As Worksheet)
Dim rngSub As Range, lastR As Long, firstAddress As String, rngUnion As Range
Dim i As Long, dict As Object
'check if more than one unique Account exists:
lastR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastR
dict(ws.Cells(i, 4).Value) = vbNullString
Next i
If dict.Count < 2 Then Exit Sub 'for only one customer code, no need of other headers...
'sort the range:
ws.UsedRange.Sort key1:=ws.UsedRange.Cells(1, 4), Order1:=xlAscending, Header:=xlYes
'place Subtotals based on Account (customer number):
ws.UsedRange.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(12), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'delete last two rows:
lastR = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
ws.Rows(lastR - 1 & ":" & lastR).Delete: 'Stop
'place all cells containing "SUBTOTAL'" in formula in a Union Range:
Set rngSub = ws.UsedRange.Columns(12).Find(What:="SUBTOTAL", After:=ws.UsedRange.Columns(12).Cells(1), LookIn:=xlFormulas, lookat:=xlPart)
If rngSub Is Nothing Then Exit Sub
firstAddress = rngSub.Address
addToRange rngUnion, rngSub
Do
Set rngSub = ws.UsedRange.FindNext(rngSub)
addToRange rngUnion, rngSub
Loop While rngSub.Address <> firstAddress
'copy the header row to the places of Subtotals rows:
With ws.Rows("1:1")
.VerticalAlignment = xlCenter
.Copy rngUnion.EntireRow 'copy the header in all Union range
End With
'remove Subtotals (needed only temporary):
ws.UsedRange.RemoveSubtotal
End Sub
Sub addToRange(rngU As Range, rng As Range) 'sub adding the new range to a Union one...
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Your existing code has only one modification: The new sub call:
rngF.Copy wsComp.Range("A1")
InsertHeaders wsComp
instead of
rngF.Copy wsComp.Range("A1")
Please, send some feedback after testing it.
I got quite a specific task that im not getting quite right, wondering if anyone could help me out.
In my code, I have a big table that gets updated monthly amongst my team, what I want to do is find the column header titled "RD" and then delete all the rows within that column containing the value "Ad-Hoc" (apart from the column header)
Sub Delete_Rows_Based_On_Value()
Dim tbl As ListObject
Set tbl = ActiveSheet.ListObjects("Table_owssvr")
Dim I As Long, finalRow As Long, L As Long
For L = tbl.Columns.Count To 1 Step -1
If Cells(1, L) = "RD" Then
For I = finalRow To 2 Step -1
If Range(L, I).Value = "Ad-Hoc" Then
Range(L, I).EntireRow.Delete
End If
Next I
End If
Next L
End Sub
wonder if anyone could help me with this and whether im on the right track. thanks
Delete Rows in Table
This will delete table rows (not worksheet rows).
The Code
Option Explicit
Sub deleteRowsBasedOnValue()
With ThisWorkbook.Worksheets("Sheet1").ListObjects("Table_owssvr")
Dim cNum As Long: cNum = .ListColumns("RD").Index
Dim dRng As Range
Dim lr As ListRow
For Each lr In .ListRows
If lr.Range.Columns(cNum).Value = "Ad-Hoc" Then
buildRange dRng, lr.Range
End If
Next lr
End With
If Not dRng Is Nothing Then
dRng.Delete
End If
End Sub
Sub buildRange( _
ByRef BuiltRange As Range, _
AddRange As Range)
If BuiltRange Is Nothing Then
Set BuiltRange = AddRange
Else
Set BuiltRange = Union(BuiltRange, AddRange)
End If
End Sub
You're on the right track. You need to use tbl.ListColumns.Count listobjects don't have a columns property.
You need to assign finalRow a value, and you have your row and column swapped looking for "Ad-Hoc"
Dim tbl As ListObject
Set tbl = ActiveSheet.ListObjects("Table_owssvr")
Dim I As Long, finalRow As Long, L As Long
For L = tbl.ListColumns.Count To 1 Step -1 'tbl.columns will error
If Cells(1, L) = "RD" Then
finalRow = Cells(Rows.Count, L).End(xlUp).Row 'Get the last row in column L
For I = finalRow To 2 Step -1
If Cells(I, L).Value = "Ad-Hoc" Then 'L is the column it goes second
Cells(I, L).EntireRow.Delete
End If
Next I
End If
Next L
Using Autofilter
Sub delete_with_filter()
Dim tbl As ListObject
Dim delrange As Range
Set tbl = ActiveSheet.ListObjects("Table_owssvr")
With tbl
.Range.AutoFilter .ListColumns("RD").Index, "Ad-Hoc"
On Error GoTo errhandler
Set delrange = .DataBodyRange.SpecialCells(xlCellTypeVisible)
If Not delrange Is Nothing Then
Application.DisplayAlerts = False
delrange.Delete
Application.DisplayAlerts = True
End If
.Range.AutoFilter .ListColumns("RD").Index
End With
errhandler:
Select Case Err.Number
Case 1004
Debug.Print "Exiting Sub, No Cells Found"
tbl.Range.AutoFilter tbl.ListColumns("RD").Index
Exit Sub
End Select
End Sub
A lot answers, but I will throw this one in for short and quick. I tested and worked.
Sub DeleteTableRows()
Dim tbl As ListObject
Set tbl = ActiveSheet.ListObjects("Table_owssvr")
tbl.Range.AutoFilter Field:=tbl.ListColumns("RD").Index, Criteria1:="Ad-Hoc"
If tbl.Range.SpecialCells(xlCellTypeVisible).Count > tbl.ListColumns.Count Then
Application.DisplayAlerts = False
tbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
End If
tbl.AutoFilter.ShowAllData
End Sub
I have a macro that runs an anti-filter concept and pastes the results into a sheet called "AF".
How can I adjust this so instead of pasting Column T from "CurrentList" it pastes columns A:Q. I tried tweaking some of the variables.
Option Explicit
Sub XC()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim src As Worksheet
Set src = wb.Worksheets("CurrentList")
Dim LastRow As Long
LastRow = src.Cells(src.Rows.Count, "S").End(xlUp).Row
Dim rng As Range
Set rng = src.Range("S1").Resize(LastRow)
Dim Lookup As Variant
Lookup = rng.Value
Set rng = src.Range("T1").Resize(LastRow)
Dim Result As Variant
Result = rng.Value
Dim LookupValue As Variant
Dim i As Long
Dim MatchCount As Long
For i = 1 To UBound(Lookup)
LookupValue = Lookup(i, 1)
If Not IsError(LookupValue) Then
If LookupValue = "Yes" Then
MatchCount = MatchCount + 1
Result(MatchCount, 1) = Result(i, 1)
End If
End If
Next i
If MatchCount = 0 Then
Exit Sub
End If
Dim dst As Worksheet
Set dst = wb.Worksheets("AF")
Set rng = dst.Cells(dst.Rows.Count, "A").End(xlUp).Offset(1)
Set rng = rng.Resize(MatchCount)
rng.Value = Result
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
Give this a try. You'll have to adjust sheet names.
Sub x()
Dim rData As Range
Application.ScreenUpdating = False
With Worksheets("CurrentList")
.AutoFilterMode = False
.Range("A1").CurrentRegion.AutoFilter field:=19, Criteria1:="Yes"
With .AutoFilter.Range
On Error Resume Next
Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rData Is Nothing Then
Intersect(rData, .Range("A:Q")).Copy Worksheets("AF").Range("A" & Rows.Count).End(xlUp)(2)
End If
End With
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
I am trying to does the following:
Compare the value (a string of characters) that is stored in column B of worksheet "State = Closed", to all the values in column A of another worksheet called "Match List".
Delete any row in the "State = Closed" that does not have a match to the corresponding "Match List" value.
The code needs to work with any length (as the number of rows will change) list in "Match List", as well as any length "State = Closed" worksheet.
Sub ListRemove()
Application.ScreenUpdating = False
Dim i As Integer
Dim b As Integer
Dim Lastrow As Long
Dim Lastrowb As Long
Dim Del As Variant
Worksheets("Match List").Activate
Set Del = Range("A1:A67") '<--- This needs to be modified to work with any length Match List
Lastrowb = Worksheets("State = Closed").Cells(Rows.Count, "A").End(xlUp).Row
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
For b = 1 To Lastrowb
If Worksheets("State = Closed").Cells(i, 2).Value <> Del(b) Then
Worksheets("State = Closed").Rows(i).EntireRow.Delete
End If
Next
Next
Application.ScreenUpdating = True
Worksheets("State = Closed").Activate
End Sub
This deletes every row in the "State = Closed" worksheet instead of just the rows that do not contain a corresponding value in the Match List worksheet.
Find my code below. Two for-loops to check for each value if there is an identical entry in any cell of the second sheet.
Sub List_Remove()
Dim i As Integer
Dim j As Integer
Dim k As Boolean
Dim shA As Worksheet
Dim shB As Worksheet
Set shA = Sheets("Sheet1") 'Worksheet that you want to compare with
Set shB = Sheets("Sheet2") 'Worksheet you want to delete rows from
For i = shB.UsedRange.Rows.Count To 1 Step -1
k = False
For j = 1 To shA.UsedRange.Rows.Count
If shB.Cells(i, 1).Value = shA.Cells(j, 1).Value Then
k = True
End If
Next
If k = False Then
shB.Rows(i).Delete
End If
Next
EndSub
This code is tested. Note use of working directly with objects.
Option Explicit
Sub ListRemove()
Application.ScreenUpdating = False
Dim matchList As Worksheet
Set matchList = Worksheets("Match List")
Dim matchRange As Range
Set matchRange = matchList.Range("A1:A" & matchList.Cells(matchList.Rows.Count, 1).End(xlUp).Row)
Dim closedList As Worksheet
Set closedList = Worksheets("State = Closed")
Dim searchRows As Long
searchRows = closedList.Cells(closedList.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = searchRows To 1 Step -1
If IsError(Application.Match(closedList.Cells(i, 1).Value, matchRange, 0)) Then
closedList.Cells(i, 1).EntireRow.Delete
End If
Next
End Sub
Delete Rows (Union)
The Code
Option Explicit
Sub ListRemove()
Application.ScreenUpdating = False
' Constants
Const mlName As String = "Match List"
Const mlFR As Long = 1
Const mlCol As Variant = "A" ' e.g. 1 or "A"
Const scName As String = "State = Closed"
Const scFR As Long = 1
Const scCol As Variant = "B" ' e.g. 1 or "A"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Match List
Dim ml As Worksheet: Set ml = wb.Worksheets(mlName)
Dim mlLR As Long: mlLR = ml.Cells(ml.Rows.Count, mlCol).End(xlUp).Row
Dim Del As Variant
Del = ml.Range(ml.Cells(mlFR, mlCol), ml.Cells(mlLR, mlCol)).Value
' State = Closed
Dim sc As Worksheet: Set sc = wb.Worksheets(scName)
Dim scLR As Long: scLR = sc.Cells(sc.Rows.Count, scCol).End(xlUp).Row
Dim rng As Range
Set rng = sc.Range(sc.Cells(scFR, scCol), sc.Cells(scLR, scCol))
' Collecting Cells
Dim cel As Range, URng As Range
For Each cel In rng.Cells
If IsError(Application.Match(cel.Value, Del, 0)) Then
GoSub collectCells
End If
Next
' Deleting Rows
'If Not URng Is Nothing Then URng.EntireRow.Delete
' First test with Hiding Rows.
If Not URng Is Nothing Then URng.EntireRow.Hidden = True
Application.ScreenUpdating = True
sc.Activate
Exit Sub
collectCells:
If Not URng Is Nothing Then
Set URng = Union(URng, cel)
Else
Set URng = cel
End If
Return
End Sub