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:
Related
I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub
I have an excel sheet, and I'm trying. to write VBA code to delete rows from the excel sheet based on the following conditions:
If Column A contains strings "string1" and "string2".
OR
If Column B contains strings "string3" or "string4"
Im using the below code:
Sub DeleteRows()
Dim rng As Range
Dim pos As Integer
Set rng = ActiveSheet.UsedRange
For i = rng.Cells.Count To 1 Step -1
pos = InStr(LCase(rng.Item(i).Value), "string1"))
If pos > 0 Then
rng.Item(i).EntireRow.Delete
End If
Next i
End Sub
But it only deletes rows if the single string is located in any column , and I couldn't specify the column name to search in.
Any help is appreciated.
Thanks,
With rng.Cells.Count you loop through all cells in the range:
Dim i As Long
For i = rng.Columns(2).Cells.Count To 1 Step -1
will only loop through the cells of column 2.
The issue is with your Loop - you're looping through each Item in the range, rather than each row
Try the below
Sub DeleteRows()
Dim rng As Range
Dim rownum As Long
Set rng = ActiveSheet.UsedRange
For rownum = rng.rows.Count To 1 Step -1
If LCase(Rng.Cells(rownum, 1) Like "*String1*" And _
LCase(rng.Cells(rownum, 1) Like "*String2*" Or _
LCase(rng.Cells(rownum, 2) Like "*String3*" Or _
LCase(rng.Cells(rownum, 2) Like "*String4*" Then
rng.Cells(rownum, 1).EntireRow.Delete
End If
Next
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
We have two worksheets.
Source worksheet is "profes"
Target worksheet is "primaria"
The data common to both worksheets is the name column.
ie: David Smith Weston appears in both worksheets.
We need to "lookup" each students name and paste values from "profes" to "primaria". I have most of the code working already BUT I don't know how to add the "lookup" part. As you can see it's wrong.
Sub Button1_Click()
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("N5:R1000") ' Do 100 rows
**If Source.Cells(j, "C").Value = Target.Cells(j, "A").Value** Then
Target.Cells(j, "N").Value = Source.Cells(j, "D").Value
j = j + 1
End If
Next c
End Sub
When comparing 2 ranges between 2 worksheets, you have 1 For loop, and replace the second loop with the Match function.
Once you loop over your "profes" sheet's range, and per cell you check if that value is found within the second range in "primaria" sheet, I used LookupRng, as you can see in the code below - you will need to adjust the range cording to your needs.
Code
Option Explicit
Sub Button1_Click()
Dim Source As Worksheet, Target As Worksheet
Dim MatchRow As Variant
Dim j As Long
Dim C As Range, LookupRng As Range
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
' set up the Lookup range in "primaria" sheet , this is just an example, modify according to your needs
Set LookupRng = Target.Range("A2:A100")
For Each C In Source.Range("N5:R1000") ' Do 100 rows
If Not IsError(Application.Match(C.Value, LookupRng, 0)) Then ' Match was successfull
MatchRow = Application.Match(C.Value, LookupRng, 0) ' get the row number from "primaria" sheet where match was found
Target.Cells(C.Row, "N").Value = Source.Cells(MatchRow, "D").Value
End If
Next C
End Sub
Use the worksheet's MATCH function to locate names from the source column C in the target's column A.
Your supplied code is hard to decipher but perhaps this is closer to what you want to accomplish.
Sub Button1_Click()
dim j as long, r as variant
dim source as worksheet, target as worksheet
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
with source
for j = 5 to .cells(.rows.count, "C").end(xlup).row
r=application.match(.cells(j, "C").value2, target.columns("A"), 0)
if not iserror(r) then
target(r, "D").resize(1, 5) = .cells(j, "N").resize(1, 5).value
end if
next j
end with
End Sub
I need the row/column combinations marked with an 'X' in my table to be available as three columns in another sheet.
The first column will consist of the cell address,
the second column will have the Row Name, and
the third column will have the Column name of the marked cells.
VLookUp and Index/Match are not helping.
Expected result:
You might get away with something as lazy as, you would change the sheets and the target range srcSht.Range("A1:C5") as appropriate:
Option Explicit
Sub test()
Dim wb As Workbook
Dim srcSht As Worksheet
Dim destSht As Worksheet
Set wb = ThisWorkbook
Set srcSht = wb.Sheets("Sheet1")
Set destSht = wb.Sheets("Sheet2")
Dim targetRange As Range
Set targetRange = srcSht.Range("A1:C5")
Dim loopArray()
loopArray = targetRange.Value2
Dim currRow As Long
Dim currCol As Long
Dim counter As Long
For currRow = LBound(loopArray, 1) To UBound(loopArray, 1)
For currCol = LBound(loopArray, 2) To UBound(loopArray, 2)
If LCase$(loopArray(currRow, currCol) )= "x" Then
counter = counter + 1
destSht.Cells(counter, 1) = targetRange.Cells(currRow, currCol).Address
destSht.Cells(counter, 2) = "Column " & targetRange.Cells(currRow, currCol).Column
destSht.Cells(counter, 3) = "Row " & targetRange.Cells(currRow, currCol).Row
End If
Next currCol
Next currRow
End Sub
This array formula seems to be working for me
=IFERROR(ADDRESS(SMALL(IF($A$1:$C$6="X",ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6)),ROW())/100,MOD(SMALL(IF($A$1:$C$6="X",ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6)),ROW()),100)),"")
but I think could be done more tidily with AGGREGATE.
Also there's no particular reason for multiplying by 100, multiplying by the exact number of columns in the array plus 1 would be better.
Here it is with AGGREGATE
=IFERROR(ADDRESS(AGGREGATE(15,6,(ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6))/($A$1:$C$6="X"),ROW())/100,MOD(AGGREGATE(15,6,(ROW($A$1:$C$6)*100+COLUMN($A$1:$C$6))/($A$1:$C$6="X"),ROW()),100)),"")
EDIT
Here is a more general solution for a 2d range of any size anywhere on the sheet.
For the row:
=IFERROR(INDEX($A$2:$A$7,AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW())/COLUMNS($B$2:$D$7)+1),"")
For the column:
=IFERROR(INDEX($B$1:$D$1,MOD(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW()),COLUMNS($B$2:$D$7))+1),"")
For the cell address:
=IFERROR(ADDRESS(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW())/COLUMNS($B$2:$D$7)+ROW($B$2),
MOD(AGGREGATE(15,6,((ROW($B$2:$D$7)-ROW($B$2))*COLUMNS($B$2:$D$7)+COLUMN($B$2:$D$7)-COLUMN($B$2))/($B$2:$D$7="X"),ROW()),COLUMNS($B$2:$D$7))+COLUMN($B$2)),"")
Here's a similar way to get a similar result:
Sub listCells()
Dim rIn As Range, c As Range, rOut As Range
Set rIn = Sheets("Sheet1").Range("B2:D7") 'input range
Set rOut = Sheets("Sheet1").Range("F1") 'first cell for output
For Each c In rIn
If c <> "" Then 'not blank so populate output
Range(rOut, rOut.Offset(, 2)) = Array(c.Address, c.Column - 1, c.Row - 1)
Set rOut = rOut.Offset(1, 0) 'next row
End If
Next c
End Sub