I've been sitting with this problem for a few hours and would be very thankful if anyone here could assist me.
What I want to do:
For all cells A10:A180 in sheet1
If cell contains a date on the form YYYY-MM-DD
Copy cell and the two next cells to the right (e.g. A11:A13)
Remove all formatting, so as to only copy the value/string of the cell.
Paste at end of column in sheet2
When finished, sort the entries (whole row) by date
Any thoughts?
Best regards
Dean
Edit: copy&pasted code from comments:
Private Sub Worksheet_Activate()
Sheet2.Cells.Clear
Dim R1 As Range, R2 As Range
Dim wsFrom As Worksheet, wsTo As Worksheet
Set wsFrom = ThisWorkbook.Sheets("Blad1")
Set wsTo = ThisWorkbook.Sheets("Blad2")
Set R1 = wsFrom.Range("A:B")
Set R2 = wsTo.Range("A:B")
R1.Copy R2
End Sub
There are some unclear points in your question, but following code should get you started how to properly load, manipulate and paste values between ranges using VBA arrays:
Option Explicit
Sub copy_nonblank()
Dim data() As Variant ' () creates an array instead of a simple variable
Dim row_count, col_count, r, c, shift As Integer
'load data from specified range into an array
data = ThisWorkbook.Sheets("Blad1").Range("A10:C180").Value2
' iterate through rows and shift data up to fill-in empty rows
row_count = UBound(data, 1)
col_count = UBound(data, 2)
shift = 0
For r = 1 To row_count
If IsEmpty(data(r, 1)) Then
shift = shift + 1
ElseIf shift > 0 Then
For c = 1 To col_count
data(r - shift, c) = data(r, c)
Next c
End If
Next r
' delete values, but not formatting
ThisWorkbook.Sheets("Blad2").Cells.ClearContents
' paste special as values, but only the shifted non-empty rows
ThisWorkbook.Sheets("Blad2").Range("A10") _
.Resize(r - shift - 1, col_count) _
.Value2 = data
End Sub
You will need to specify the formatting on the output sheet manually, but only once.
Related
HERE IS A NEW IMAGE HOPEFULLY SHOWING WHAT HAS TO MOVE AND WHERE'Here is a sample of some code I have been trying.
sub
For Each cel In Range("W2:W1000")
If cel.Value = "Credit Adj W/O To Collection" AND
Range("AI2:AI1000").Cells.Value > "" THEN
cel.Offset(0,-9).value =
end sub
Basically I need to look in column W for a specific text and if it is found move the number in the next column, col X over to column Y in the same row as the data in column AI, but in column Y. My issue is the amount of rows it has to move up is different based on where the data is in column AI. See screenshot
All of you have been a great help but it is still not moving any numbers. I added another screenshot. I need to look for the text in blue, if found move the amount in column X two columns right and up to the row that has a value in column AI. That gap could be different for each entry, as shown in the screen shot. could be 2 or 4 or 5, just depends on Column AI. Also first entry may not always start in the same row as it does here. The spot in column W and AI may be different throughout the spreadsheet. Hope this helps define my purpose a little.
Everyone has had great ideas but still not working, logic in answers makes sense but it is not grabbing any of the data much less move it. Not sure what is up.
Try this:
Sub tester()
Dim c As Range, ws As Worksheet, rw As Range
Set ws = ActiveSheet 'always use an explicit sheet reference
For Each c In ws.Range("W2:W1000").Cells
Set rw = c.EntireRow 'the whole row for the cell
If c.Value = "Credit Adj W/O To Collection" And _
IsNumeric(rw.Columns("X").Value) Then
'copy the value to Col Y in the row above which has a value in Col AI
ws.Cells(rw.Columns("AI").End(xlUp).Row, "Y").Value = rw.Columns("X").Value
rw.Columns("X").ClearContents ' clear the "X" value
End If
Next c
End Sub
A Tricky Column Update
Loop (r = r + 1) from the first row to the last row (the latter calculated in column W).
When column AI is not blank, write the row number to a variable (rFound).
Continue looping (r = r + 1). When column W is equal to the string Credit Adj W/O To Collection, write the value in column X of the current row to column Y of the row kept in the variable (rFound).
Continue looping (r = r + 1) by alternating between steps 2. and 3. until the last row.
Option Explicit
Sub UpdateInsAmt()
Const wsName As String = "Sheet1"
Const rStart As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rLast As Long: rLast = ws.Cells(ws.Rows.Count, "W").End(xlUp).Row
Dim r As Long: r = rStart
Dim rFound As Long
Do
If Len(CStr(ws.Cells(r, "AI").Value)) > 0 Then ' is not blank
rFound = r
r = r + 1 ' it can't be in the same row
Do
If StrComp(CStr(ws.Cells(r, "W").Value), _
"Credit Adj W/O To Collection", vbTextCompare) = 0 Then
ws.Cells(rFound, "Y").Value = ws.Cells(r, "X").Value
Exit Do ' value found and written so stop looping ...***
'Else ' value not found ...
End If
r = r + 1 ' ... so incremenet row
Loop Until r > rLast
' Else ' is blank ...
End If
r = r + 1 ' ... so increment row, ...*** and increment row
Loop Until r > rLast
End Sub
I am looking to deal with a couple of problems here:
We have a spreadsheet from a client that consists of 150 odd tabs of the same daily work form. In each work form, thankfully in the same positions, are a date in C4 and a list of works carried out starting in B10.(the works carried out vary in a number of cells; some have 3 some have 8 etc... so a list
redacted sheet, partial
What I need to do is, copy the works carried out into the database sheet, Column B, then copy the date from C4 (in the works sheet) into column A (of the database sheet), for each one of the works carried out. (so if there are 5 tasks carried out it would copy in the date to Column A 5 times. I then need to do that for all the tabs, so it is in one list.
There is a gap below the list of works of 1 cell then more data, this is the same above... noit sure if End(xlUp) or End(xldown)would be usable.
multiple tabs macro - the issue is it copies to each tab, not a single tab
Sub DateCLM()
DateCLM Macro
Date Column
Dim xSh As Worksheet
Application.ScreenUpdating = False
For Each xSh In Worksheets
xSh.Select
Call RunCode
Next
Application.ScreenUpdating = True
End Sub
Currently trying to figure this out and not getting anywhere.. any help would be appreciated.
Matt
How can I copy a column of cells in excel, with VBA, until there is a
blank and paste it into a new sheet?
Here is an algorithm I came up with years ago to solve this problem.
Create variables for the first and last cells in your range
Set the value of the first cell in the range, i.e. B10
Select the first cell in the range
While active cell is not empty
select the next cell down
end while
select the range of cells between your two variables
---perform some action---
I don't have access to the original file, nor have I used VBA for years, but I've given it a go. Hopefully this will give you a help in the right direction?
Sub selectRange()
'Create variables for the first and last cells in your range
Dim firstCell As Range
Dim lastCell As Range
'Set the value of the first cell in the range, i.e. B10
firstCell = Range("B10")
'Select the first cell in the range
firstCell.Select
firstCell.Activate
'Loop while cell is empty
While Not ActiveCell = ""
ActiveCell.Offset(1, 0).Activate
Wend
'After empty cell is found, activate last non-empty cell
ActiveCell.Offset(-1, 0).Activate
lastCell = ActiveCell
'Select the range of cells between your two variables
ActiveSheet.Range(firstCell, lastCell).Select
'---perform some action---
End Sub
Copy From Multiple Worksheets
It is assumed that the data is consistent:
Database is a worksheet in the same workbook as the worksheets to be processed,
all dates are in cell C4 and are actual dates,
all other data is located from cell B10 to before (above) the first blank cell below.
Adjust the values in the constants section.
The Code
Option Explicit
Sub copyFromMultipleWorksheets()
Const wsName As String = "Database"
Const wsCell As String = "A2"
Const datesCell As String = "C4"
Const worksFirstCell As String = "B10"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsCount As Long: wsCount = wb.Worksheets.Count
' Define Arrays.
Dim Works As Variant: ReDim Works(1 To wsCount - 1)
Dim Dates() As Date: ReDim Dates(1 To wsCount - 1)
Dim RowsCount() As Long: ReDim RowsCount(1 To wsCount - 1)
Dim OneValue As Variant: ReDim OneValue(1 To 1, 1 To 1)
' Declare additional variables.
Dim ws As Worksheet ' Source Worksheet
Dim rg As Range ' Source Range
Dim rCount As Long ' Rows Count
Dim tRows As Long ' Total Rows (for Data Array)
Dim n As Long ' Worksheets, Dates, Works Arrays, RowCounts Counter
For Each ws In wb.Worksheets
If ws.Name <> wsName Then
' Define Works Range.
With ws.Range(worksFirstCell)
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rg = rg.Find("", rg.Cells(rg.Rows.Count), xlFormulas)
Debug.Print rg.Address
Set rg = .Resize(rg.Row - .Row)
End With
' Count, write date and count some more.
n = n + 1
Dates(n) = ws.Range(datesCell).Value
rCount = rg.Rows.Count
RowsCount(n) = rCount
tRows = tRows + rCount
' Write values from Works Range to current array of Works Array.
If rCount > 1 Then
Works(n) = rg.Value
Else
Works(n) = OneValue: Works(n)(1, 1) = rg.Value
End If
End If
Next ws
' Write values from arrays of Works Array to Data Array.
Dim Data As Variant: ReDim Data(1 To tRows, 1 To 2)
Dim i As Long, k As Long
For n = 1 To n
For i = 1 To RowsCount(n)
k = k + 1
Data(k, 1) = Dates(n)
Data(k, 2) = Works(n)(i, 1)
Next i
Next n
' Write values from Data Array to Destination Range.
With wb.Worksheets(wsName).Range(wsCell).Resize(, 2)
Application.ScreenUpdating = False
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(k).Value = Data
Application.ScreenUpdating = True
End With
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
I'm novice in VBA. I'm trying to transpose my data:
I would like to have this results:
I tried all day the methodes like: Resize(UBound(Table2, 1), UBound(Table2, 2)) = Table2, Application.transpose(Tbl1) but I don't have the diserid result. Could you help me please? Thank you very much!
A Power Query Solution (CVR)
Added corrections; credits to Ron Rosenfeld.
Click into your table.
Select Data > From Table/Range: The Power Query Editor opens containing your data.
The first columns is selected. If not, click the header of your first column (Date) to select it.
Select Transform > Pivot Column: The Pivot Column window opens.
In the Values Column combo box the second column (Values) is already selected. If not, select it.
Click Advanced Options where Sum is already selected which will sum multiple entries for the same ID/Date columns. If not, select it.
Press OK. The data is transformed.
Select Home > Close & Load: The Power Query Editor closes and the transformed data is presented in a table in a new worksheet.
Short Version
Click into your table.
Select Data > From Table/Range: The Power Query Editor opens containing your data.
Select Transform > Pivot Column: The Pivot Column window opens.
Press OK. The data is transformed.
Select Home > Close & Load: The Power Query Editor closes and the transformed data is presented in a table in a new worksheet.
With Office365 you can use below formulas (as per my screenshot).
F2=UNIQUE(C1:C11)
G1=TRANSPOSE(SORT(UNIQUE(A1:A10)))
G2=FILTER($B$1:$B$11,($C$1:$C$11=$F2)*($A$1:$A$11=G$1),"")
After putting FILTER() formula to G2 cell drag across right and down as needed.
You can also use XLOOKUP() instead of FILTER() formula to G2 like-
=XLOOKUP(1,($A$1:$A$11=G$1)*($C$1:$C$11=$F2),$B$1:$B$11,"")
Pivot CVR
CVR: Column Labels, Values, Row Labels.
It is assumed that the initial data, the Source Range, contains a row of headers, whose third cell value will be copied to the first cell of the resulting data, the Destination Range.
Adjust the values in the constants section.
Copy the complete code to a standard module, e.g. Module1.
Only run the first procedure, pivotDataCVR, the other two are being called by it, when necessary.
A similar solution, which I based this solution on, although RCV, can be found here.
The Code
Option Explicit
Sub pivotDataCVR()
' Define constants.
Const srcName As String = "Sheet1"
Const srcFirst As String = "A1"
Const dstName As String = "Sheet2"
Const dstFirst As String = "A1"
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Source First Cell Range.
Dim cel As Range
Set cel = wb.Worksheets(srcName).Range(srcFirst)
' Define Source Range.
Dim rng As Range
With cel.CurrentRegion
Set rng = cel.Resize(.Rows.Count + .Row - cel.Row, _
.Columns.Count + .Column - cel.Column)
End With
' Get unique values.
Dim dts As Variant
dts = getUniqueColumn1D(rng.Columns(1).Resize(rng.Rows.Count - 1).Offset(1))
sort1D dts
Dim idx As Variant
idx = getUniqueColumn1D(rng.Columns(3).Resize(rng.Rows.Count - 1).Offset(1))
sort1D idx
' Write values from Source Range to Source Array.
Dim Source As Variant
Source = rng.Value
' Define Destination Array.
Dim Dest As Variant
ReDim Dest(1 To UBound(idx) - LBound(idx) + 2, _
1 To UBound(dts) - LBound(dts) + 2)
' Write values from arrays to Destination Array.
Dest(1, 1) = Source(1, 3)
Dim n As Long
Dim i As Long
i = 1
For n = LBound(idx) To UBound(idx)
i = i + 1
Dest(i, 1) = idx(n)
Next n
Dim j As Long
j = 1
For n = LBound(dts) To UBound(dts)
j = j + 1
Dest(1, j) = dts(n)
Next n
For n = 2 To UBound(Source, 1)
i = Application.Match(Source(n, 3), idx, 0) + 1
j = Application.Match(Source(n, 1), dts, 0) + 1
Dest(i, j) = Source(n, 2)
Next n
' Define Destination First Cell Range.
Set cel = wb.Worksheets(dstName).Range(dstFirst)
' Define Destination Range.
Set rng = cel.Resize(UBound(Dest, 1), UBound(Dest, 2))
' Write from Destination Array to Destination Range.
rng.Value = Dest
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
' Returns the unique values from a column range in a 1D array.
Function getUniqueColumn1D(ColumnRange As Range, _
Optional ByVal Sorted As Boolean = False) _
As Variant
Dim Data As Variant
Data = ColumnRange.Columns(1).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
Dim Key As Variant
Dim i As Long
For i = 1 To UBound(Data, 1)
Key = Data(i, 1)
If Not IsError(Key) And Not IsEmpty(Key) Then
.Item(Key) = Empty
End If
Next i
If .Count > 0 Then
getUniqueColumn1D = .Keys
End If
End With
End Function
' Sorts a 1D array only if it contains values of the same data type.
Sub sort1D(ByRef OneD As Variant, _
Optional ByVal Descending As Boolean = False)
With CreateObject("System.Collections.ArrayList")
Dim i As Long
For i = LBound(OneD) To UBound(OneD)
.Add OneD(i)
Next i
.Sort
If Descending Then
.Reverse
End If
OneD = .ToArray
End With
End Sub
I have an Excel table which may contain such:
Screenshot of content from a table, columns C and D
It may be much longer
on top of column D may be an empty cell, but after that it is always the same sequence of contents repeating.
I want to copy and paste in another sheet, with transpose, the contents of the neighboring cells, that is in C, so it would look like:
a screenshot from destination table
It is easy to copy the header, but I am completely unable to have the code loop through and copy all the column C contents that appear left to what is between 1tst and 27tst in the original column D, until all of the blocks of data are copied.
To complicate things even further, I want all empty cells in this destination table to take the value from the cell above, basically filling the blanks that way. This would then look like
Final look of the destination table
In this example, the Words "Algeria | DZ" have to be automatically copied down. The cell under "24tst" remains blank as there is nothing but the header preceding this row.
I have absolutely no starting code here, as these data already made a long process from a Word file through a csv using Ruby, and then the csv is read in and reformatted into various sheets in the Excel file with already long line sof code. That all works so far, but these are my missing steps.
Any help is greatly appreciated. I only started coding again 3 weeks ago, after having never programmed in VBA but years ago in perl and R.
-- In response to VBasic2008 and to try that out I made now a test spreadsheet that looks this way:this is closer to what it really looks like
I changed the constants here:
enter code hereConst sName As String = "Tabelle1" ' Source Worksheet Name
enter code hereConst sFirst As String = "C2" ' Source First Cell Address
enter code hereConst tName As String = "Tabelle2" ' Target Worksheet Name
enter code hereConst tFirst As String = "B1" ' Target First Cell Address
The groups will actually be constant in length, actually more than 11, but that can be fixed later.
These:
1tst
2tst
3tst
11tst
4tst
22tst
23tst
24tst
25tst
26tst
27tst -
I pasted this already into target sheet.
What I get from my test using my thus modified solution from VBasic2008 is this:
Afghanistan | AF Åland Islands | AX Albania | AL Algeria | DZ American Samoa | AS Belgium | BE Belize | BZ 24tst Bermuda | BM Bhutan | BT Bolivia | BO
Bonaire, Sint Eustatius and Saba | BQ Bosnia and Herzegovina | BA Botswana | BW Algeria | DZ Brazil | BR Christmas Island | CX Cocos (Keeling) Islands | CC Colombia | CO Comoros | KM n/a Congo | CD
This is almost perfect, except for it should not, in the first row in the target sheet after the headers, copied down the "24tst". Can this still be tweaked?
A Copy Transpose
This will work correctly only if the data is consistent i.e. 11 rows of data and 1 empty (Next-Group) row (can be changed in the constants section) i.e. if you have 5 data sets, there has to be 60 rows of data. If there is 65, only 60 will be processed and if there is 59, only 48 will be processed.
The following image shows what the current setup in the code will produce (without the formatting).
The Code
Option Explicit
Sub transposeData()
Const sName As String = "Sheet1" ' Source Worksheet Name
Const sFirst As String = "A2" ' Source First Cell Address
Const tName As String = "Sheet1" ' Target Worksheet Name
Const tFirst As String = "D1" ' Target First Cell Address
Const NoE As Long = 11 ' Number of Elements
Const NoER As Long = 1 ' Number of Empty Rows
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Worksheet ('ws').
Dim ws As Worksheet
Set ws = wb.Worksheets(sName)
' Define Source First Cell ('First').
Dim First As Range
Set First = ws.Range(sFirst)
' Define Source Last Cell ('Last').
Dim Last As Range
Set Last = First.Offset(ws.Rows.Count - First.Row, 1).End(xlUp)
If Last.Row - First.Row + 1 < NoE Then
GoTo ProcExit
End If
' Define Source Range ('rng').
Dim rng As Range
Set rng = ws.Range(First, Last)
' Write values from Source Range to Source Array ('Source').
Dim Source As Variant
Source = rng.Value
' Define number of Data Sets ('NoDS').
Dim NoDS As Long
NoDS = Int(UBound(Source, 1) / (NoE + NoER))
' Define Target Number of Rows ('NoR').
Dim NoR As Long
NoR = NoDS + 1
' Define Target Array ('Target').
Dim Target As Variant
ReDim Target(1 To NoR, 1 To NoE)
' Declare additional variables for the upcoming loops.
Dim CurrentValue As Variant ' Source Current Value
Dim CurrentLR As Long ' Source Current Last Row
Dim j As Long ' Target Columns Counter
Dim i As Long ' Target Rows Counter
' Write headers.
For j = 1 To NoE
Target(1, j) = Source(j, 2)
Next j
' Write data.
For i = 2 To NoR
CurrentLR = (i - 2) * (NoE + NoER)
For j = 1 To NoE
CurrentValue = Source(CurrentLR + j, 1)
If Not IsEmpty(CurrentValue) Then
Target(i, j) = CurrentValue
Else
Target(i, j) = Target(i - 1, j)
End If
Next j
Next i
' Define Target Worksheet ('ws').
Set ws = wb.Worksheets(tName)
' Define Target First Cell ('First').
Set First = ws.Range(tFirst)
' Define Target Range ('rng').
Set rng = First.Resize(NoR, NoE)
' Write values from Target Array to Target Range.
rng.Value = Target
' Inform user
MsgBox "Data transferred.", vbInformation, "Success"
ProcExit:
End Sub
EDIT
Tiny Change
Instead of Target(i, j) = Target(i - 1, j) use
If i > 2 Then
Target(i, j) = Target(i - 1, j)
End If
I think the easiest way of doing this is looping through cells with headers and checking each value.
When you find your "next-group" cell then trigger some ifs;
Example program which covers your problem below:
Sub solution()
'Set first row
Dim firstrow As Integer
firstrow = 1
'Find last row
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row 'Go to bottom of file and jump up to last non-empty cell
'Set first column
Dim firstcolumn As Integer
firstcolumn = 1
'find last column
Dim lastcolumn As Integer
lastcolumn = 2
'Set first cell of target table
Dim targetrange As Range
Set targetrange = Range("E2")
Dim i As Integer
Dim cnt As Integer 'conuter for creating offset (for columns)
Dim cnt2 As Integer 'conuter for creating offset (for rows)
'Copy headers
cnt = 0
For i = firstrow To lastrow
If Cells(i, lastcolumn).Value = "next-group" Then Exit For
Cells(i, lastcolumn).Copy targetrange.Offset(0, cnt)
cnt = cnt + 1
Next i
'Copy data
cnt = 0
cnt2 = 1
For i = firstrow To lastrow
'If we have text "next group"
If Cells(i, lastcolumn).Value = "next-group" Then
cnt = 0 'start with first column
cnt2 = cnt2 + 1 'Start with next row
'This cell is not copied
Else
'cell is copied
Cells(i, firstcolumn).Copy targetrange.Offset(cnt2, cnt)
'column counter is increased
cnt = cnt + 1
End If
Next i
'Change blank cells in current region into formula which points to cell one row above
'targetrange.CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
'Same formula but keep cells in first row of data blank istead copying header
Dim targetArea As Range
Set targetArea = targetrange.CurrentRegion
targetArea.Offset(2).Resize(targetArea.Rows.Count - 2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I didn't cover case when you have empty cell in first row as you didn't described what you're expecting (at this moment it have same formula so it will be filled with header value).
UPDATE: I didnt put "=" inside R1C1 formula, now its fixed.
UPDATE2: Changed part of filling empty cells so it skips first 2 rows (Headers and first row of data) instead filling it as mentioned in question update
All -
I have a 2 sheet excel.
Sheet 1 is three columns (name, date, value)
Sheet 2 is name.
I want to write a VBA script that displays all of Sheet 1 data that does NOT have any of the name field listed in Sheet 2 anywhere in sheet 1 (name can appear in different columns so ideally it would search all cells in Sheet 1) to appear in sheet 3
See the sample image for a rough idea of what I"m hoping to accomplish. I have searched but have not had luck.
If you have Excel 365 you can use the Dynamic Array formulas
=LET(Names,FILTER(Sheet1!$C:$E,Sheet1!$C:$C<>""),FILTER(Names,ISERROR(MATCH(INDEX(Names,,1),Sheet2!$G:$G,0))))
Example:
Data (Sheet1)
Exclusion List (Sheet2)
Result
Note: this excludes the headers because the header label Name is present in both the Data column and the Exclusion column so be sure to maintain that
Without Excel 365. I'd recommend a UDF
Function FilterList(ByVal Data As Range, ByVal Exclusion As Range) As Variant
Dim Res As Variant
Dim Dat As Variant
Dim Excl As Variant
Dim rw As Long
Dim idx As Long
Dim cl As Long
Dim ExcludeIt As Variant
Dim Cols As Long
Dim TopRow As Long
ReDim Res(1 To Application.Caller.Rows.Count, 1 To Application.Caller.Columns.Count)
If IsEmpty(Data.Cells(1, 1)) Then
TopRow = Data.Cells(1, 1).End(xlDown).Row
Set Data = Data.Resize(Data.Rows.Count - TopRow).Offset(TopRow - 1)
End If
If IsEmpty(Data.Cells(Data.Rows.Count, 1)) Then
Set Data = Data.Resize(Data.Cells(Data.Rows.Count, 1).End(xlUp).Row - Data.Row + 1)
End If
Dat = Data.Value
Excl = Exclusion.Columns(1).Value
Cols = Application.Min(UBound(Dat, 2), UBound(Res, 2))
idx = 0
For rw = 1 To UBound(Dat, 1)
ExcludeIt = Application.Match(Dat(rw, 1), Excl, 0)
If IsError(ExcludeIt) Then
idx = idx + 1
For cl = 1 To Cols
Res(idx, cl) = Dat(rw, cl)
Next
End If
Next
For rw = 1 To UBound(Res, 1)
For cl = IIf(rw <= idx, UBound(Dat, 2) + 1, 1) To UBound(Res, 2)
Res(rw, cl) = vbNullString
Next
Next
FilterList = Res
End Function
Enter it as an Array Formula (complete it with Ctrl+Shift+Enter) in a range large enough to hold the returned data (can be larger), and pass it your input Data range and Exclusion range (both as whole columns)
=FilterList(Sheet1!$C:$E,Sheet2!$G:$G)
Welcome to Stack Overflow!
You did not say where the source table and criteria table begin, or where to place the result of the "anti-filter". I wrote this code on the assumption that they all start at the first cell of the worksheet, A1:
Sub AntiFilter()
Dim aSource As Range, aCriteria As Range, oCell As Range, oTarget As Range, countCells As Long
Set aSource = Worksheets("Sheet1").Range("A1").CurrentRegion
countCells = aSource.Columns.Count
Set aCriteria = Worksheets("Sheet2").Range("A1").CurrentRegion
Set oTarget = Worksheets("Sheet3").Range("A1")
aSource.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=aCriteria, Unique:=False
For Each oCell In Application.Intersect(aSource, aSource.Columns(1))
If oCell.RowHeight < 1 Then
oCell.Resize(1, countCells).Copy Destination:=oTarget
Set oTarget = oTarget.Offset(1, 0)
End If
Next oCell
On Error Resume Next
aSource.Worksheet.ShowAllData
On Error GOTO 0
End Sub
Workbook with macro, test data and examples of selection criteria on Sheet2
If the macro does not work as expected, make sure that you have sheets named Sheet1, Sheet2, and Sheet3 in your workbook, and that the source data range and criteria range start with cells A1. If this is not the case, make the necessary changes to the text of the macro: