I am using the below code to set an array to the values in a Named Range (containing account numbers) and then use that array as the criteria to AutoFilter a table (Table1).
Sub FilterRangeCriteria()
Dim vCrit As Variant
Dim rngCrit As Range
Set rngCrit = wsL.Range("CritList")
vCrit = rngCrit.Value
wsO.ListObjects("Table1").Range.AutoFilter _
Field:=8, _
Criteria1:=vCrit, _
Operator:=xlFilterValues
End Sub
I can see that the array contains all of the values from the named range however the table that I'm trying to filter will eliminate all rows below the header and not show any rows with the criteria from the named range.
This will work if CritList is a single column or row. Otherwise, you'll have to create a 1D array from the values.
Sub FilterRangeCriteria()
Dim vCrit As Variant
Dim rngCrit As Range
Set rngCrit = wsL.Range("CritList")
vCrit = WorksheetFunction.Transpose(WorksheetFunction.Unique(rngCrit))
wsO.ListObjects("Table1").Range.AutoFilter _
Field:=8, _
Criteria1:=vCrit, _
Operator:=xlFilterValues
End Sub
EDIT
For the filter to work properly, the numeric values need to be converted to strings.
Sub FilterRangeCriteria()
Dim vCrit As Variant
Dim rngCrit As Range
Set rngCrit = wsL.Range("CritList")
vCrit = WorksheetFunction.Transpose(WorksheetFunction.Unique(rngCrit))
Rem Numeric filter values need to be converted to strings
Dim n As Long
For n = LBound(vCrit) To UBound(vCrit)
vCrit(n) = CStr(vCrit(n))
Next
wsO.Range("A11").CurrentRegion.AutoFilter Field:=8, Criteria1:=vCrit, Operator:=xlFilterValues
End Sub
Filter Excel Table Column on Values of a Named Range
Sub FilterRangeCriteria()
' Source - read criteria list
' 'wsL' is the code name of a worksheet containing this code
Const sRangeName As String = "CritList"
' Destination - filter a table
' 'wsO' is the code name of a worksheet containing this code
Const dtblName As String = "Table1"
Const dlcName As String = "Ledger Account"
' Keep in mind that this would fail on 'UBound(cData, 1)'
' if there was only one cell in the named range.
Dim cData As Variant: cData = wsL.Range(sRangeName).Value
' "AutoFilter" 'likes' strings and the array needs to be 1D,
' hence write the values from the 2D one-based one-column criteria array,
' converted to strings, to a 1D one-based string array ('sArr').
Dim sArr() As String: ReDim sArr(1 To UBound(cData, 1))
Dim r As Long
For r = 1 To UBound(cData, 1)
sArr(r) = CStr(cData(r, 1))
Next r
' Reference the destination table.
Dim dtbl As ListObject: Set dtbl = wsO.ListObjects(dtblName)
Application.ScreenUpdating = False
' Remove any filters.
If dtbl.ShowAutoFilter Then
If dtbl.AutoFilter.FilterMode Then dtbl.AutoFilter.ShowAllData
Else
dtbl.ShowAutoFilter = True
End If
' Reference the destination table criteria column.
Dim dlc As ListColumn: Set dlc = dtbl.ListColumns(dlcName)
' Apply the filter.
dtbl.Range.AutoFilter dlc.Index, sArr, xlFilterValues
Application.ScreenUpdating = True
' Inform.
MsgBox "Table filtered.", vbInformation
End Sub
Related
I'm creating a macro that is formatting a collection of files and a step in this process is to delete columns that aren't required, keeping a specific set of columns.
I know I can delete columns based on their location and I have this approach implemented already ie 1,3,7 etc or A, C, G etc. But I'm conscious that the report being used might change layout or add extra columns over time and I want to ensure the required columns are kept.
Ideally this code would cycle through each column header starting at A1 until the last column and delete an entire column if the header value isn't found in a list. This list will be an array captured from a range in one of the sheets in the workbook.
List = {Blue, Green, Orange}
Original Table
Blue
Red
Green
Orange
Black
row
row
row
row
row
Formatted Table
Blue
Green
Orange
row
row
row
Does anyone have any suggestions on the approach I could take to get this working or if it's even possible? Any help would be greatly appreciated
You might profit from the following approach by reordering a datafield array via Application.Index which allows even to move the existing columns to any new position.
Note: this flexible solution can be time consuming for greater data sets,
where I would prefer other ways you can find in a lot of answers at SO.
Sub ReorderColumns()
Const headerList As String = "Blue,green,Orange"
'a) define source range
Dim src As Range
Set src = Tabelle3.Range("A1:E100")
'b) define headers
Dim allHeaders: allHeaders = src.Resize(1).Value2
Dim newHeaders: newHeaders = Split(headerList, ",")
'c) get column positions in old headers
Dim cols
cols = getCols(newHeaders, allHeaders)
'd) define data
Dim data As Variant
data = src.Value2
'e) reorder data based on found column positions
data = Application.Index(data, Evaluate("row(1:" & UBound(data) & ")"), cols)
'f) overwrite source data
src = vbNullString ' clear
src.Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help function getCols()
Function getCols(individualHeaders, allHeaders)
'Purp: get 1-based column numbers of found headers via Match
getCols = Application.Match(individualHeaders, allHeaders, 0) ' 1-based
End Function
Please, test the next code. It is compact and fast enough. It will build the columns to be deleted range using Application.Match for the two involved arrays (the existing headers one and the ones to be kept). This code assumes that the headers exist in the first row of the processed sheets, starting from A:A column (If starting from a different column, the code can be adapted:
Sub DeleteColunsNotInArrayDel()
Dim sh As Worksheet, arrStay, lastCol As Long, arrH, arrCols, rngDel As Range
Set sh = ActiveSheet 'use here the sheet you need to process
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
arrH = Application.Transpose(Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2)) 'existing headers array
arrCols = Application.IfError(Application.match(arrH, arrStay, 0), "xx") 'match the two arrays and place "xx" where no match has been found
makeColsRng(arrCols).Delete 'delete the columns range, at once
End Sub
Function makeColsRng(arr) As Range
Dim i As Long, colL As String, strAddr As String
For i = LBound(arr) To UBound(arr) 'iterate between the matched arrays array
If arr(i) = "xx" Then 'for the not matching case:
colL = Split(cells(1, i).Address, "$")(1) 'extract the letter of the respective column
strAddr = strAddr & colL & "1," 'build the string of the columns to be deleted range
End If
Next i
Set makeColsRng = Range(left(strAddr, Len(strAddr) - 1)).EntireColumn 'return the necessary range
End Function
In case of headers not starting from the first sheet column, the function can easily be adapted by adding a new parameter (the first column number) to be added when the range to be deleted is built.
The above suggested solution is a fancy one, just for the sake of showing the respective approach, which is not too often used. It may have a limitation of the range building, in case of a string bigger than 254 digits, No error handling for the case of everything matching (even, easy to be added). The next version is standard VBA, compact, more reliable, faster and easier to be understood:
Sub DeleteColunsRangeNotInArray()
Dim sh As Worksheet, arrStay, lastCol As Long, rngH As Range, rngDel As Range, i As Long
Set sh = ActiveSheet
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
Set rngH = sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)) 'existing headers range
For i = 1 To rngH.Columns.count
If IsError(Application.match(rngH(i).Value, arrStay, 0)) Then 'if not a match in arrStay:
addToRange rngDel, rngH(i) 'build a Union range
End If
Next i
'delete the not necessary columns at once:
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Dynamic Named Range
I think a dynamic named range is an excellent choice for storing and retrieving your required columns. Please see the link I provided from https://exceljet.net/ to setup your dynamic named range.
Generic formula =$A$2:INDEX($A:$A,COUNTA($A:$A))
Regular Expression Approach
After reading in your named range, one approach for testing your columns is using regular expressions. To use this you will need to set a library reference to Microsoft VBScript Regular Expressions 5.5. The pipe character | represents an or statement, so we can join our array using that delimiter.
Deleting Ranges in loops
When deleting columns or rows within a loop, the best approach I have found is to union the ranges together in a variable and execute the deletion in one go. This helps performance and it prevents errors from deleting ranges the loop is working on.
I do this so often that I created a custom function for this UnionRange
' Helper function that allows
' concatinating ranges together
Public Function UnionRange( _
ByRef accumulator As Range, _
ByRef nextRange As Range _
)
If accumulator Is Nothing Then
Set UnionRange = nextRange
Else
Set UnionRange = Union(accumulator, nextRange)
End If
End Function
Putting it all together
Below is my implementation of what your code could look like, just make sure to first:
Create a Dynamic Named Range and populate with your required headers
Add Microsoft VBScript Regular Expressions 5.5 reference
Update Sheet1 to whatever sheet your table exists (possibly change logic for finding header row based on your needs)
' Need Regular Expressions Referenced in order to work!
' #libraryReference {Microsoft VBScript Regular Expressions 5.5}
Public Sub DemoDeletingNonRequiredColumns()
' Make sure to create a named range
' otherwise this section will fail. In this
' example the named range is `RequiredColumns`
Dim requiredColumns() As Variant
requiredColumns = Application.WorksheetFunction.Transpose( _
Range("RequiredColumns").Value2 _
)
' To test if the column is in the required
' columns this method uses regular expressions.
With New RegExp
.IgnoreCase = True
' The pipe charactor is `or` in testing.
.Pattern = Join(requiredColumns, "|")
Dim headerRow As Range
' This example uses `Sheet1`, but update to
' the actual sheet you are using.
With Sheet1
Set headerRow = .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
End With
Dim column As Range
For Each column In headerRow
' If the column name doesn't match the
' pattern, then concatenate it to the
' toDelete range.
If Not .Test(column.Value2) Then
Dim toDelete As Range
Set toDelete = UnionRange(toDelete, column.EntireColumn)
End If
Next
End With
' toDelete is used as it provides better performance
' and it also prevents errors when deleting columns
' while looping.
If Not toDelete Is Nothing Then
toDelete.Delete
Set toDelete = Nothing
End If
End Sub
Delete Columns Not In a List
Option Explicit
Sub DeleteIrrelevantColumns()
' Source - the worksheet containing the list of headers.
Const sName As String = "Sheet2"
Const sFirstCellAddress As String = "A2"
' Destination - the worksheet to be processed.
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim sData() As Variant
With sfCell
Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
sData = .Resize(slCell.Row - .Row + 1).Value
End With
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim sValue As Variant
Dim sr As Long
For sr = 1 To UBound(sData)
sValue = sData(sr, 1)
If Not IsError(sValue) Then ' exclude error values
If Len(sValue) > 0 Then ' exclude blanks
sDict(sValue) = Empty ' write
End If
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range
With dfCell
Dim dlCell As Range: Set dlCell = _
.Resize(, dws.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
Set drg = .Resize(, dlCell.Column - .Column + 1)
End With
Dim dData() As Variant: dData = drg.Value
Dim dCells As Range
Dim dValue As Variant
Dim dc As Long
For dc = 1 To UBound(dData, 2)
dValue = dData(1, dc)
If sDict.Exists(dValue) Then
' If duplicate columns, keep only the left-most.
sDict.Remove dValue
Else
' Combine the irrelevant header cells into a range.
If dCells Is Nothing Then
Set dCells = drg.Cells(dc)
Else
Set dCells = Union(dCells, drg.Cells(dc))
End If
End If
Next dc
' Delete columns in one go.
If Not dCells Is Nothing Then
dCells.EntireColumn.Delete
End If
' Inform.
If sDict.Count = 0 Then
MsgBox "Irrelevant columns deleted.", vbInformation
Else
MsgBox "Irrelevant columns deleted." & vbLf & vbLf _
& "Columns not found:" & vbLf _
& Join(sDict.Keys, vbLf), vbCritical
End If
End Sub
I'm trying to to run a command if these arguments checks , but it's giving me incompatibily type on that block, what am I doing wrong?
Dim rn as range
For Each rg In Columns("X")
If rg.Value Like "?*#?*.?*" And _
LCase(Cells(rg.Row, "U").Value) = "Demande de création d'intervention" _
And LCase(Cells(rg.Row, "V").Value) <> "envoyé" Then
Comparing Strings
If you loop through the cells of the whole column, it will take forever. Calculate the last row, the row of the last non-empty cell in the column, instead.
LCase(Something) will never be equal to Demande.... Use demande... instead.
If you use CStr to convert a value to a string, you won't have to worry about the value being incompatible when comparing it to another string.
The Code
Option Explicit
Sub Test()
Const FirstRow As Long = 2
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "X").End(xlUp).Row
' If LastRow < FirstRow Then
' MsgBox "No data in column.", vbCritical
' Exit Sub
' End If
' Reference the column range ('rg').
Dim rg As Range
Set rg = ws.Range(ws.Cells(FirstRow, "X"), ws.Cells(LastRow, "X"))
' Reference the other column ranges ('rg2', 'rg3')
Dim rg2 As Range: Set rg2 = rg.EntireRow.Columns("U")
Dim rg3 As Range: Set rg3 = rg.EntireRow.Columns("V")
' Note that all three ranges are of the same size.
' Declare additional variables to be use in the loop.
Dim Cell As Range ' Current cell in the first range
Dim cString As String ' String Representation of the Current Cell's Value
Dim r As Long ' Index of the Current Cell
' Use 'CStr' to convert the values to strings to avoid an error occurring
' if the cell contains an error value.
For Each Cell In rg.Cells ' note '.Cells'
r = r + 1 ' count the cells (in this case rows)
cString = CStr(Cell.Value)
If cString Like "?*#?*.?*" _
And LCase(CStr(rg2.Cells(r).Value)) _
= "demande de création d'intervention" _
And LCase(CStr(rg3.Cells(r).Value)) <> "envoyé" Then
' Do your thing, e.g.
Debug.Print r, cString
End If
Next Cell
End Sub
Results in the Immediate window (Ctrl+G).
8 FY#I.NV
11 MF#X.UT
14 EU#X.IF
I am trying to find people who are missing their street address and moving their row to a separate tab in my sheet.
Sub NEW_NoAddress()
Const Title As String = "Move Data Rows"
Const scCol As Long = 6
Const dCol As Long = 1
Const Criteria As String = "ISEmpty()"
' Remove any previous filters.
If Sheet1.AutoFilterMode Then
Sheet1.AutoFilterMode = False
End If
' Filter.
Dim srg As Range ' Source Range (Headers and Data)
Set srg = Sheet1.Range("A1").CurrentRegion
srg.AutoFilter scCol, Criteria
' Count the number of matches.
Dim sdrg As Range ' Source Data Range (Without Headers)
Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
Dim sdccrg As Range ' Source Data Criteria Column Range
Set sdccrg = sdrg.Columns(scCol)
Dim drCount As Long ' Destination Rows Count (Matches Count)
drCount = Application.Subtotal(103, sdccrg)
' Move if there are matches.
If drCount > 0 Then ' matches found
Dim sdfrrg As Range ' Source Data Filtered Rows Range
Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
Dim dCell As Range ' Destination Cell
Set dCell = Sheet10.Cells(Sheet10.Rows.Count, dCol).End(xlUp).Offset(1, 0)
With sdfrrg
.Copy dCell
' Either delete the entire worksheet rows...
'.EntireColumn.Delete
' ... or remove filter to prevent...
Sheet1.AutoFilterMode = False
' ... deleting the entire worksheet rows leaving possible data
' to the right (after the empty column) intact.
.Delete xlShiftUp
End With
Else ' no matches
Sheet1.AutoFilterMode = False
End If
End Sub
I tried "<>", "<> **", " "" ", I think I tried one that had vbStringISNull, (), and other things I came across in Google. I considered going the other direction and keeping the <> to move those who have an address, but I'd rather move the incorrect entries to my exceptions tab.
Move Matching Rows
I'm glad you like my code. Unfortunately, it has a big mistake:
drCount = Application.Subtotal(103, sdccrg)
which is similar to Excel's ACOUNT which results in 0 when selecting blanks.
I've seen this in a couple of codes and adopted it as valid. Was I in for a surprise.
When you plan on using such a code so intensely, you want to move the changing variables to the arguments section to easily use it many times (see the long procedure below).
You can use the new procedure...
... for your first question like this:
Sub MoveMatchRows()
MoveMatchingRows Sheet1, 4, "FD.Matching Gifts FY22", Sheet2, 1, False
End Sub
... for yesterday's question like this:
Sub NEW_Move_Stock_InKind_DAF()
MoveMatchingRows Sheet1, 44, "<>*/*", Sheet8, 1, False
End Sub
... and for today's question like this:
Sub NewNoAddress()
MoveMatchingRows Sheet1, 6, "=", Sheet10, 1, False
End Sub
I have declared SourceCriteria as variant and added xlFilterValues to be able to use multiple criteria, e.g. Array("1", "2").
The Procedure
Sub MoveMatchingRows( _
ByVal SourceWorksheet As Worksheet, _
ByVal SourceColumn As Long, _
ByVal SourceCriteria As Variant, _
ByVal DestinationWorksheet As Worksheet, _
Optional ByVal DestinationColumn As Long = 1, _
Optional ByVal DoClearPreviousDestinationData As Boolean = False)
Const ProcTitle As String = "Move Matching Rows"
' Remove any previous filters.
If SourceWorksheet.AutoFilterMode Then
SourceWorksheet.AutoFilterMode = False
End If
' Filter.
Dim srg As Range ' Source Range (Headers and Data)
Set srg = SourceWorksheet.Range("A1").CurrentRegion
srg.AutoFilter SourceColumn, SourceCriteria, xlFilterValues
' Create a reference to the Source Data Range (no headers).
Dim sdrg As Range
Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
' Clear Destination worksheet.
If DoClearPreviousDestinationData Then ' new data, copies headers
DestinationWorksheet.Cells.Clear
End If
' Attempt to create a reference to the Source Data Filtered Rows Range.
Dim sdfrrg As Range
On Error Resume Next
Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not sdfrrg Is Nothing Then
' Create a reference to the Destination Cell (also, add headers).
Dim dCell As Range ' Destination Cell
Set dCell = DestinationWorksheet.Cells(1, DestinationColumn)
If IsEmpty(dCell) Then
srg.Rows(1).Copy dCell
Set dCell = dCell.Offset(1)
Else
Set dCell = DestinationWorksheet.Cells( _
DestinationWorksheet.Rows.Count, DestinationColumn) _
.End(xlUp).Offset(1, 0)
End If
With sdfrrg
.Copy dCell
' Either delete the entire worksheet rows...
'.EntireColumn.Delete
' ... or remove filter to prevent...
SourceWorksheet.AutoFilterMode = False
' ... deleting the entire worksheet rows leaving possible data
' to the right (after the empty column) intact.
.Delete xlShiftUp
End With
Else ' no matches
SourceWorksheet.AutoFilterMode = False
End If
End Sub
I have put together the following code to copy a range of IDs. The range contains many duplicates and I just want to paste one occurrence of each ID.
I keep getting a syntax error and I can't see what I am doing wrong. Can anyone point out the issue?
Thanks
Sub CopyIDs()
With ThisWorkbook.Sheets("DataTable").Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ThisWorkbook.Sheets("Analysis").Range("A8"), Unique:=True
ThisWorkbook.Sheets("Analysis").Range("A8").Delete Shift:=xlShiftUp
End With
End Sub
You use "With" and "End With" in an incorrect way.
If you want to skip to specify the "Date Table" sheets twice, you may refer below code
With ThisWorkbook.Sheets("DataTable")
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ThisWorkbook.Sheets("Analysis").Range("A8"), Unique:=True
End With
Advanced Filter vs Dictionary
The following contains 2 Advanced Filter solutions and 2 Dictionary solutions the latter using the getUniqueColumn function.
The Code
Option Explicit
' Stand-Alone
Sub copyIDsQF()
' To prevent 'Run-time error '1004':
' The extract range has a missing or invalid field name.':
ThisWorkbook.Worksheets("Analysis").Range("A8").ClearContents
With ThisWorkbook.Worksheets("DataTable")
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=ThisWorkbook.Worksheets("Analysis").Range("A8"), _
Unique:=True
End With
ThisWorkbook.Worksheets("Analysis").Range("A8").Delete Shift:=xlShiftUp
End Sub
' Stand-Alone
Sub CopyIDsCool()
With ThisWorkbook
' Define Source Column Range.
Dim SourceRange As Range
With .Worksheets("DataTable")
' If you ars sure that the range is contiguous:
Set SourceRange = .Range("A1", .Range("A1").End(xlDown))
' If not, rather use the following:
'Set SourceRange = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
' but then you could have the empty string as a unique value.
End With
' Define Target First Cell Range.
Dim TargetFirstCell As Range
Set TargetFirstCell = .Worksheets("Analysis").Range("A8")
End With
Application.ScreenUpdating = False
' To prevent 'Run-time error '1004':
' The extract range has a missing or invalid field name.':
TargetFirstCell.ClearContents
' Copy unique values from Source Column Range to Target Column Range.
SourceRange.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=TargetFirstCell, _
Unique:=True
' Delete Target First Cell Range i.e. remove copied header.
TargetFirstCell.Delete Shift:=xlShiftUp
Application.ScreenUpdating = True
End Sub
' Uses the getUniqueColumn Function.
Sub CopyIDsMagicNumbers()
' Write unique values from Source Column to Data Array ('Data').
Dim Data As Variant
Data = getUniqueColumn(ThisWorkbook.Worksheets("DataTable"), "A", 2)
' Validate Data Array.
If IsEmpty(Data) Then
GoTo ProcExit
End If
' Write values from Data Array to Target Range.
With ThisWorkbook.Worksheets("Analysis").Range("A8")
' Clear contents in Target Column from Target First Cell to bottom.
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
' Write values from Data Array to Target Range.
.Resize(UBound(Data, 1)).Value = Data
End With
ProcExit:
End Sub
' Uses the getUniqueColumn Function.
Sub CopyIDs()
' Source
Const srcName As String = "DataTable"
Const UniCol As Variant = "A"
Const FirstRow As Long = 2
' Target
Const tgtName As String = "Analysis"
Const tgtFirstCell As String = "A8"
' Workbook
Dim wb As Workbook
Set wb = ThisWorkbook
' Write unique values from Source Column to Data Array ('Data').
Dim Data As Variant
Data = getUniqueColumn(wb.Worksheets(srcName), UniCol, FirstRow)
' Validate Data Array.
If IsEmpty(Data) Then
GoTo ProcExit
End If
' Write values from Data Array to Target Range.
With wb.Worksheets(tgtName).Range(tgtFirstCell)
' Clear contents in Target Column from Target First Cell to bottom.
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
' Write values from Data Array to Target Range.
.Resize(UBound(Data, 1)).Value = Data
End With
ProcExit:
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values of a column range
' in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getUniqueColumn(Sheet As Worksheet, _
Optional ByVal ColumnIndex As Variant = 1, _
Optional ByVal FirstRow As Long = 1) _
As Variant
' Validate worksheet.
If Sheet Is Nothing Then
GoTo ProcExit ' Worksheet is 'Nothing'.
End If
' Define Processing Range ('rng').
Dim rng As Range
Set rng = Sheet.Columns(ColumnIndex) _
.Resize(Sheet.Rows.Count - FirstRow + 1) _
.Offset(FirstRow - 1)
' Define Last Non-Empty Cell ('cel') in Processing Range.
Dim cel As Range
Set cel = rng.Find(What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
' Validate Last Non-Empty Cell.
If cel Is Nothing Then
GoTo ProcExit ' Processing Range is empty.
End If
' Define Non-Empty Column Range ('rng').
Set rng = rng.Resize(cel.Row - FirstRow + 1)
' Write values from Non-Empty Column Range to Data Array ('Data').
Dim Data As Variant
If rng.Rows.Count > 1 Then
Data = rng.Value
Else
ReDim Data(1, 1)
Data(1, 1) = rng.Value
End If
' Write values from Data Array to Unique Dictionary ('dict').
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim Key As Variant
Dim i As Long
For i = 1 To UBound(Data)
Key = Data(i, 1)
If Not IsError(Key) And Not IsEmpty(Key) Then
dict(Key) = Empty
End If
Next i
' Validate Unique Dictionary.
If dict.Count = 0 Then
GoTo ProcExit ' There are only error and/or empty values in Data Array.
End If
' Write values from Unique Dictionary to Data Array ('Data').
ReDim Data(1 To dict.Count, 1 To 1)
i = 0
For Each Key In dict.Keys
i = i + 1
Data(i, 1) = Key
Next Key
' Write Data Array to result.
getUniqueColumn = Data
ProcExit:
End Function
I want to using sumifs function in VBA. And result paste in same column as previous data.
Twice a SUMIF with Overwrite
Workbook
Download
(Dropbox)
Couldn't find any indication of SUMIFS, so I did it as if there is
twice a SUMIF:
For Columns A and C, and for Columns B and D.
Option Explicit
Sub SumUnique(UniqueFirstCell As Range, ValueFirstCell As Range)
Dim rng As Range ' Unique Last Used Cell
Dim dict As Object ' Dictionary
Dim key As Variant ' Dictionary Key Counter (For Each Control Variable)
Dim vntU As Variant ' Unique Range Array
Dim vntV As Variant ' Value Range Array
Dim vntUT As Variant ' Unique Array
Dim vntVT As Variant ' Value Array
Dim curV As Variant ' Current Value
Dim NorS As Long ' Source Number of Rows
Dim NorT As Long ' Target Number of Rows
Dim i As Long ' Source/Target Row Counter
' Copy Unique Range to Unique Range Array.
With UniqueFirstCell
Set rng = .Worksheet.Columns(.Column) _
.Find("*", , xlFormulas, , , xlPrevious)
Set rng = .Resize(rng.Row - .Row + 1)
End With
vntU = rng
' Copy Value Range to Value Range Array.
With ValueFirstCell
Set rng = .Worksheet.Columns(.Column) _
.Find("*", , xlFormulas, , , xlPrevious)
Set rng = .Resize(rng.Row - .Row + 1)
End With
vntV = rng
' Create Unique Values and SumIf Values in Dictionary.
Set dict = CreateObject("Scripting.Dictionary")
NorS = UBound(vntU)
For i = 1 To NorS
curV = vntU(i, 1)
If curV <> "" Then
dict(curV) = dict(curV) + vntV(i, 1)
End If
Next
NorT = dict.Count
' Resize Unique and Value Arrays to Target Number of Rows.
ReDim vntUT(1 To NorT, 1 To 1)
ReDim vntVT(1 To NorT, 1 To 1)
i = 0
For Each key In dict.keys
i = i + 1
' Write Dictionary Keys to Unique Array.
vntUT(i, 1) = key
' Write Dictionary Values to Value Array.
vntVT(i, 1) = dict(key)
Next
' Copy Unique Array to Target Unique Range.
With UniqueFirstCell
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
rng.ClearContents
Set rng = .Resize(NorT)
End With
rng = vntUT
' Copy Value Array to Target Value Range.
With ValueFirstCell
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
rng.ClearContents
Set rng = .Resize(NorT)
End With
rng = vntVT
End Sub
Sub Uni()
Uni1
Uni2
End Sub
Sub Uni1()
Const cUni As String = "A2"
Const cVal As String = "C2"
With ThisWorkbook.Worksheets("Sheet1")
SumUnique .Range(cUni), .Range(cVal)
End With
End Sub
Sub Uni2()
Const cUni As String = "B2"
Const cVal As String = "D2"
With ThisWorkbook.Worksheets("Sheet1")
SumUnique .Range(cUni), .Range(cVal)
End With
End Sub
I created two command buttons and put the following code into the sheet module:
Option Explicit
Private Sub cmdRevert_Click()
[A2:D31] = [J2:M31].Value
End Sub
Private Sub cmdUnique_Click()
Uni
End Sub
You can use SumIfs in VBA through the Application or WorksheetFunction object with VBA style range references. You are only going to want to use it once for each pair of column A and column B values. If you use it once then loop to another row with the same pair of column A and column B values, you cannot use it again without getting false results due to the changes you made the first time.
However, those false results are okay if you are just going to delete them anyways and RemoveDuplicates deletes from the bottom up leaving the top-most column A and column B pairs with the correct totals.