I am completely new to visual basic. I have a few spreadsheets containing numbers. I want to delete any rows containing numbers outside of specific ranges. Is there a straightforward way of doing this in visual basic?
For example, in this first spreadsheet (image linked) I want to delete rows that contain cells with numbers outside of these two ranges: 60101-60501 and 74132-74532.
Can anyone give me some pointers? Thanks!
Code
You need to call it for your own needs as shown on the routine "Exec_DeleteRows". I assumed that you needed if it is equals or less to the one that you state on your routine. In this example, I will delete the rows where values are between 501-570 and then the ones between 100-200
Sub Exec_DeleteRows()
Call Exec_DeleteRowsInRangeBasedOnNumberValue(Range("C8:H11"), 501, 570)
Call Exec_DeleteRowsInRangeBasedOnNumberValue(Range("C8:H11"), 100, 200)
End Sub
Sub Exec_DeleteRowsInRangeBasedOnNumberValue(RangeToWorkIn As Range, NumPivotToDeleteRowBottom As Double, NumPivotToDeleteRowTop As Double)
Dim RangeRowsToDelete As Range
Dim ItemRange As Range
For Each ItemRange In RangeToWorkIn
If IsNumeric(ItemRange.Value) = False Then GoTo SkipStep1
If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop Then ' 1. If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop
If RangeRowsToDelete Is Nothing Then ' 2. If RangeRowsToDelete Is Nothing
Set RangeRowsToDelete = RangeToWorkIn.Parent.Rows(ItemRange.Row)
Else ' 2. If RangeRowsToDelete Is Nothing
Set RangeRowsToDelete = Union(RangeToWorkIn.Parent.Rows(ItemRange.Row), RangeRowsToDelete)
End If ' 2. If RangeRowsToDelete Is Nothing
End If ' 1. If ItemRange.Value >= NumPivotToDeleteRowBottom And ItemRange.Value <= NumPivotToDeleteRowTop
SkipStep1:
Next ItemRange
If Not (RangeRowsToDelete Is Nothing) Then RangeRowsToDelete.EntireRow.Delete
End Sub
Demo
Delete Rows Containing Wrong Numbers
It is assumed that the data starts in A1 of worksheet Sheet1 in the workbook containing this code (ThisWorkbook) and has a row of headers (2).
This is just a basic example to get familiar with variables, data types, objects, loops, and If statements. It can be improved on multiple accounts.
Option Explicit
Sub DeleteWrongRows()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' worksheet
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' range
Application.ScreenUpdating = False
Dim rrg As Range ' Row Range
Dim rCell As Range ' Cell in Row Range
Dim rValue As Variant ' Value in Cell
Dim r As Long ' Row
Dim DoDelete As Boolean
' Loop backwards through the rows of the range.
For r = rg.Rows.Count To 2 Step -1
Set rrg = rg.Rows(r)
' Loop through cells in row.
For Each rCell In rrg.Cells
rValue = rCell.Value
If IsNumeric(rValue) Then ' is a number
If rValue >= 60101 And rValue <= 60501 Then ' keep
ElseIf rValue >= 74132 And rValue <= 74532 Then ' keep
Else ' delete (outside the number ranges)
DoDelete = True
End If
Else ' is not a number
DoDelete = True
End If
If DoDelete Then ' found a cell containing a wrong value
rCell.EntireRow.Delete
DoDelete = False
Exit For ' no need to check any more cells
'Else ' found no cell containing a wrong value (do nothing)
End If
Next rCell
Next r
Application.ScreenUpdating = True
MsgBox "Rows with wrong numbers deleted.", vbInformation
End Sub
Using Range.Delete is the built-in way of completely erasing a row in Excel VBA. To check an entire row for numbers meeting a certain criteria, you would need a Loop and an If Statement.
To evaluate a lot of values at a faster pace, it is smart to first grab the relevant data off the Excel sheet into an Array. Once in the array, it is easy to set up the loop to run from the first element (LBound) to the final element (UBound) for each row and column of the array.
Also, when deleting a lot of Ranges from a worksheet, it is faster and less messy to first collect (Union) the ranges while you're still looping, and then do the delete as a single step at the end. This way the Range addresses aren't changing during the loop and you don't need to re-adjust in order to track their new locations. That and we can save a lot of time since the application wants to pause and recalculate the sheet after every Deletion.
All of those ideas put together:
Sub Example()
DeleteRowsOutside ThisWorkbook.Worksheets("Sheet1"), Array(60101, 60501), Array(74132, 74532)
End Sub
Sub DeleteRowsOutside(OnSheet As Worksheet, ParamArray Min_and_Max() As Variant)
If OnSheet Is Nothing Then Set OnSheet = ActiveSheet
'Find the Bottom Corner of the sheet
Dim BottomCorner As Range
Set BottomCorner = OnSheet.Cells.Find("*", After:=OnSheet.Range("A1"), SearchDirection:=xlPrevious)
If BottomCorner Is Nothing Then Exit Sub
'Grab all values into an array
Dim ValArr() As Variant
ValArr = OnSheet.Range(OnSheet.Cells(1, 1), BottomCorner).Value
'Check each row value against min & max
Dim i As Long, j As Long, DeleteRows As Range
For i = LBound(ValArr, 1) To UBound(ValArr, 1) 'For each Row
For j = LBound(ValArr, 2) To UBound(ValArr, 2) 'For each column
Dim v As Variant: v = ValArr(i, j)
If IsNumeric(v) Then
Dim BoundaryPair As Variant, Is_Within_A_Boundary As Boolean
Is_Within_A_Boundary = False 'default value
For Each BoundaryPair In Min_and_Max
If v >= BoundaryPair(0) And v <= BoundaryPair(1) Then
Is_Within_A_Boundary = True
Exit For
End If
Next BoundaryPair
If Not Is_Within_A_Boundary Then
'v is not within any acceptable ranges! Mark row for deletion
If DeleteRows Is Nothing Then
Set DeleteRows = OnSheet.Rows(i)
Else
Set DeleteRows = Union(DeleteRows, OnSheet.Rows(i))
End If
GoTo NextRow 'skip to next row
End If
End If
Next j
NextRow:
Next i
If Not DeleteRows Is Nothing Then DeleteRows.EntireRow.Delete
End Sub Exit For 'skip to next row
End If
End If
Next j
Next i
If Not DeleteRows Is Nothing Then DeleteRows.EntireRow.Delete
End Sub
I use a ParamArray to accept a variable number of Min and Max ranges. To keep things tidy, the Min and Max pairs are each in an array of their own. As long as all the numbers in the row are within any of the provided ranges, the row will not be deleted.
Here's some code with Regex and with scripting dictionary that I've been working on. I made this for my purposes, but it may be useful here and to others.
I found a way for selecting noncontinguous cells based on an array and then deleting those cells.
In this case, I selected by row number because VBA prevented deletion of rows due to overlapping ranges.
Sub findvalues()
Dim Reg_Exp, regexMatches, dict As Object
Dim anArr As Variant
Dim r As Range, rC As Range
Set r = Sheets(3).UsedRange
Set r = r.Offset(1).Resize(r.Rows.Count - 1, r.Columns.Count)
Set Reg_Exp = CreateObject("vbscript.regexp")
With Reg_Exp
.Pattern = "^[6-6]?[0-0]?[1-5]?[0-0]?[1-1]?$|^60501$" 'This pattern is for the 60101 to 60501 range.
End With
Set dict = CreateObject("Scripting.Dictionary")
For Each rC In r
If rC.Value = "" Then GoTo NextRC ''skip blanks
Set regexMatches = Reg_Exp.Execute(rC.Value)
If regexMatches.Count = 0 Then
On Error Resume Next
dict.Add rC.Row & ":" & rC.Row, 1
End If
NextRC:
Next rC
On Error GoTo 0
anArr = Join(dict.Keys, ", ")
Sheets(3).Range(anArr).Delete Shift:=xlShiftUp
End Sub
I am trying to search down a column of an excel sheet for identical text which is an argument of the function.
Function getRow(callerID As String) As Integer
Dim CalcRow As Integer
Dim CurrRow As Integer
Dim CurrCol As Integer
Dim SearchSheet As Worksheet
'Define variables
Set SearchSheet = ThisWorkbook.Worksheets("Calculations")
Set CellSearch = SearchSheet.Cells(CurrRow,CurrCol)
CalcRow = 2
CurrRow = 2
CurrCol = 16
Do Until CellSearch.Value = ""
If callerID = CellSearch.Value Then
Exit Do
Else
CurrRow = CurrRow + 1
CalcRow = CalcRow + 1
End If
Loop
'set return value
getRow = CalcRow
End Function
It keeps saying this is an error: Set CellSearch = SearchSheet.Cells(CurrRow,CurrCol) when I try to refer to it as a range.
I've tried referring to the range in other ways --I just want to increment the row by 1 until each cell in that column with a value is searched.
I'm very new to VBA so I've had some trouble with referring to cells without using ActiveCell. I don't want to use ActiveCell for this.
Get the Worksheet Row of the First Occurrence of a String in a Column
To allow to find other data types (Numbers, Dates, Booleans...) you only have to change
callerID As Variant
Note that Application.Match is case-insensitive i.e. MYSTRING = mystring. Also, it is handled differently than WorksheetFunction.Match i.e. its result can be tested with IsError or IsNumeric while the WorksheetFunction version will raise an error if no match is found.
Range.Resize Property
Keep in mind that the Range.Find method is unreliable if the worksheet is filtered.
The Code
Option Explicit
Function getRow(callerID As String) As Long
' Define the First Cell
With ThisWorkbook.Worksheets("Calculations").Range("P2")
' Calculate the Row Offset which is utilized with resize
' and when writing the result.
Dim RowOffset As Long: RowOffset = .Row - 1
' Declare a range variable.
Dim rg As Range
' Attempt to define the Last Non-Empty Cell.
Set rg = .Resize(.Worksheet.Rows.Count - RowOffset) _
.Find("*", , xlFormulas, , , xlPrevious)
' Validate the Last Non-Empty Cell.
If Not rg Is Nothing Then
' Define the Column Range, the range from the First Cell
' to the Last Non-Empty Cell in the worksheet column.
Set rg = .Resize(rg.Row - RowOffset)
' Attempt to find the Index (position) of the Caller ID
' in the Column Range.
Dim cIndex As Variant: cIndex = Application.Match(callerID, rg, 0)
' Validate the Index i.e. check if the Caller ID was found.
If IsNumeric(cIndex) Then
' Write the result. Note that the Index is the position
' in the Column Range, so to return the position (row)
' in the worksheet, the Row Offset has to be added.
getRow = cIndex + RowOffset
'Else ' Caller ID was not found (cIndex is an error value).
End If
'Else ' The range from the First Cell to the bottom-most cell
' of the worksheet column is empty.
End If
End With
End Function
Return dynamic array from function VBA got me part of the way on this problem. I realized I should know size prior to invoking the function.
Function GetHeadersFromRange(DataRange As Range, Size As Integer) As Variant
Dim Column As Integer
Dim Headers As Variant
ReDim Headers(0 To Size)
For Column = 1 To DataRange.Columns.Count
Headers(Column) = DataRange(1, Column).Value
Next
GetHeadersFromRange = Headers
End Function
Sub TestGetHeadersFromRange()
Application.DisplayAlerts = False
Set wb = ThisWorkbook
Set TestSheet = wb.Sheets.Add()
TestSheet.Range("A1").Value = "my_header"
TestSheet.Range("A2").Value = "val"
Dim DataRange As Range: Set DataRange = TestSheet.Range("A1:A2")
Dim Size As Integer: Size = DataRange.Columns.Count
Dim Result As Variant
' Gets type mismatch
Set Result = GetHeadersFromRange(DataRange, Size)
End Sub
Not entirely sure what to do here. I need to use this function in multiple places which is why it is a function in the first place.
Edit: Clarify problem
Set Result = GetHeadersFromRange(...) gets a type mismatch.
Header Function
Improvement
Your error occurs because you are using Set (used for objects)
on an array.
A more efficient (faster) way than looping through a range is looping
through an array.
When you copy a range to a variant (possibly array), if the range
contains one cell, the variant will contain one value only. But if
the range contains multiple cells, it will be an array, whose size is
returned with UBound. Therefore there is no need for a Size argument.
IsArray is used to determine if a variant is an array. In our case we can check if the number of columns (elements) is greater than 1 instead.
Option Explicit
Function GetHeadersFromRange(DataRange As Range) As Variant
Dim vntR As Variant ' Range Variant
Dim vntH As Variant ' Header Array
Dim Noe As Long ' Number of Elements
Dim j As Long ' Range Array Column Counter,
' Header Array Element Counter
With DataRange
' Calculate Number of Elements.
Noe = .Columns.Count
' Calculate Header Range.
' Copy Header Range to Range Variant.
vntR = .Resize(1, Noe)
' Note: Range Variant (vntR) is a 2D 1-based 1-row array only if
' DataRange contains more than one column. Otherwise it is
' a variant containing one value.
End With
'' Check if Range Variant is an array.
'If IsArray(vntR) Then
' Check if Number of Elements is greater than 1.
If Noe > 1 Then
' Resize 1D 0-based Header Array to number of columns (2) in Range
' Array minus 1 (0-based).
ReDim vntH(Noe - 1)
' Loop through columns of Range Array.
For j = 1 To Noe
' Write value at first row (1) and current column (j) of Range
' Array to current element (j-1) of Header Array.
vntH(j - 1) = vntR(1, j)
Next
Else
' Resize 1D 0-based Header Array to one element only (0).
ReDim vntH(0)
' Write Range Variant value to only element of Header Array.
vntH(0) = vntR
End If
GetHeadersFromRange = vntH
End Function
Sub TestGetHeadersFromRange()
Dim TestSheet As Worksheet ' Source Worksheet
Dim DataRange As Range ' Data Range
Dim Result As Variant ' Result Variant (possibly Array)
Dim i As Long ' Result Array Element Counter
' Add a new worksheet (Source Worksheet).
' Create a reference to the newly added Source Worksheet.
Set TestSheet = ThisWorkbook.Sheets.Add()
' In Source Worksheet
With TestSheet
' Add some values.
.Range("A1").Value = "my_header"
.Range("A2").Value = "val"
.Range("B1").Value = "my_header2"
.Range("B2").Value = "val2"
End With
' Test 1:
Debug.Print "Test1:"
' Create a reference to DataRange.
Set DataRange = TestSheet.Range("A1:A2")
' Write Data Range to 1D 0-based Result Array.
Result = GetHeadersFromRange(DataRange)
' Loop through elements of Result Array.
For i = 0 To UBound(Result)
' Write current element of Result Array to Immediate window.
Debug.Print Result(i)
Next
' Test 2:
Debug.Print "Test2:"
' Create a reference to DataRange.
Set DataRange = TestSheet.Range("A1:B2")
' Write Data Range to 1D 0-based Result Variant.
Result = GetHeadersFromRange(DataRange)
' Loop through elements of Result Array.
For i = 0 To UBound(Result)
' Write current element of Result Array to Immediate window.
Debug.Print Result(i)
Next
End Sub
I would like to make a macro that copies numbers that fall under the same category and add them up separately for each category. For instance Cells in column c contain the name of the product than 4 columns to the right is the number of sold products. I would like to add up all the entries in the number of sold products that fall under the same product together for each product and write it out to a predefined cell. So far I have come up with this
Sub find()
Dim XXX As Range
Dim myTotal As Long
Dim name As String
Dim name2 As String
name = Range("C2")
For Each XXX In Range("C2:C99999")
name2 = ActiveCell.Value
If name <> name2 Then
Dim aa As Integer
aa = 1
Cells(aa, 8).Value = name
Cells(aa, 9).Value = myTotal
name = name2
myTotal = 0
aa = aa + 1
End If
If InStr(XXX.Value, name2) > 0 Then
myTotal = myTotal + XXX.Offset(0, 4).Value
End If
Next XXX
End Sub
Any tips or guidelines would be appreciated and I hope the explanation makes sense.
Here's a faster basic approach:
Sub find()
Dim dict As Object, names, nums, r As Long
Dim sht As Worksheet
Set sht = ActiveSheet
Set dict = CreateObject("scripting.dictionary")
names = Range("C2:C99999").Value
nums = Range("C2:C99999").Offset(0, 4).Value
For r = 1 To UBound(names)
dict(names(r, 1)) = dict(names(r, 1)) + nums(r, 1)
Next r
WriteCounts dict, sht.Range("J1")
End Sub
Sub WriteCounts(dict As Object, rngStart As Range)
Dim k
For Each k In dict.keys
rngStart.Value = k
rngStart.Offset(0, 1).Value = dict(k)
Set rngStart = rngStart.Offset(1, 0)
Next k
End Sub
The Dictionary 'SumIf' Feature
VBA Dictionary Solution
Credits to Tim Williams and
his
solution.
Why would OP want a VBA solution when there is a perfectly good Excel
solution? When there are tens of thousands of records and as many or
many times more formulas, the workbook tends to get slow. So by adding
the SUMIF formula we're adding another bunch of them slowing down
even more. And we don't know the unique values, which we could find
using another seriously slowing down formula.
So VBA will do this in a split second, or will it? I created a new
worksheet with 60000 records and with 1000 unique ones to try to
prove it.
SumIf Solution: The first idea was to adjust all the ranges, get the unique values using Advanced Filter and then use
Worksheetfunction.SumIf. SumIf took its time, 17s, and when I
added some formulas it went above 20s.
Array Loop Solution: This one was again using Advanced Filter but this time the idea was to put everything into arrays and loop
through them and adding the values to another array one by one. This
time the loop took its time. After some tweaking it went down to 13s
and stayed there even after adding formulas.
Advanced Filter did copy the unique values in less than 0.2s into
the appropriate range, but the rest was taking too long.
Dictionary Solution: Tim Williams' solution did initially do all this in 2.5s. How is that possible I thought, Advanced Filter is the god
of unique values. Well, it isn't, or at best it is only one of them. I saw
this line in a loop in the code: dict(names(r, 1)) = dict(names(r, 1)) + nums(r, 1). It seemed like it was doing the heavy lifting in a split second which forced me to investigate (Dictionary Object (Microsoft), Excel VBA Dictionary: A Complete Guide (Paul Kelly) and produce a
solution.
The Code
Sub SumIfToTarget3() ' Array Dictionary ... 0.2-0.3s
' Name
Const cNsht As Variant = "Sheet2" ' Name Worksheet Name/Index
Const cNrow As Long = 1 ' Name First Row Number
Const cNcol As Long = 3 ' Name Column Number
Const cVcol As Long = 7 ' Value Column Number
' Target
Const cTsht As Variant = "Sheet2" ' Target Worksheet Name/Index
Const cTrow As Long = 1 ' Target First Row Number
Const cUcol As Long = 8 ' Unique Column Number
Const cUnique As String = "Unique" ' Unique Column Header
Const cSumIf As String = "Total" ' SumIf Column Header
' Create a reference to the Dictionary Object.
'*******************************************************
' Early Binding (0.1s Faster) *
' You have to go to Tools>References and check (create *
' a reference to) "Microsoft Scripting Runtime" . *
' Dim dict As New Dictionary ' *
'*******************************************************
'**************************************************
' Late Binding (0.1s Slower) *
' You don't need to create a reference. *
Dim dict As Object ' *
Set dict = CreateObject("Scripting.Dictionary") ' *
'**************************************************
Dim dk As Variant ' Dictionary 'Counter' (For Each Control Variable)
Dim CurV As Variant ' Current Value
Dim rngN As Range ' Name Column Range, Last Used Cell in Name Column,
' Name Range with Headers, Name Range
Dim rngV As Range ' Value Range
Dim rngT As Range ' Target Columns Range, Target Range
Dim vntN As Variant ' Name Array
Dim vntV As Variant ' Value Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Name/Value Array Element (Row) Counter,
' Target Array Row Counter, Target Array Rows Count
' (Dictionary Items Count)
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle Errors.
On Error GoTo ErrorHandler
' In Unique Column
With ThisWorkbook.Worksheets(cTsht).Columns(cUcol)
' Create a reference to Target Columns Range (rngT) i.e. the range in
' Unique Column (cUcol) from Target First Row (cTrow) to the bottom row
' of Target Worksheet (cTsht), resized by a column for SumIf Column (2).
Set rngT = .Resize(.Rows.Count - cTrow + 1, 2).Offset(cTrow - 1)
End With
' Clear contents of Target Columns Range (rngT).
rngT.ClearContents
' Write Unique Column Header to 1st Cell of Target Columns Range.
rngT.Cells(1) = cUnique
' Write SumIf Column Header to 2nd Cell of Target Columns Range.
rngT.Cells(2) = cSumIf
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Calculate Last Used Cell in Name Column.
Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Name Range with headers.
Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
End With
' Calculate Name Range (without headers).
Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
' Copy Name Range (rngN) to Name Array (vntN).
vntN = rngN
' Calculate Value Range (without headers).
Set rngV = rngN.Offset(, cVcol - cNcol)
' Copy Value Range (rngV) to Value Array (vntV).
vntV = rngV
' Loop through elements (rows) of Name Array.
For i = 1 To UBound(vntN)
' Write element in current row (i) of Value Array (vntV) to Current
' Value.
CurV = vntV(i, 1)
' Check if Current Value (CurV) is NOT a number.
If Not IsNumeric(CurV) Then
' Assign 0 to Current Value.
CurV = 0
End If
' Add current element (row) in Name Array (vntN) and Current Value
' to the Dictionary. If the key to be added is new (not existing),
' the new key and the item will be added. But if the key exists, then
' the existing item will be increased by the value of the new item.
' This could be called "The Dictionary SumIf Feature".
dict(vntN(i, 1)) = dict(vntN(i, 1)) + CurV
Next
' Reset Name/Value Array Element (Row) Counter to be used as
' Target Array Row Counter.
i = 0
' Resize Target Array to the number of items in the Dictionary.
ReDim vntT(1 To dict.Count, 1 To 2)
' Loop through each Key (Item) in the Dictionary.
For Each dk In dict.Keys
' Increase Target Array Row Counter (count Target Array Row).
i = i + 1
' Write current Dictionary Key to element in current (row) and
' 1st column (Unique) of Target Array.
vntT(i, 1) = dk
' Write current Dictionary Item to element in current (row) and
' 2nd column (SumIf) of Target Array.
vntT(i, 2) = dict(dk)
Next
' Calculate Target Range (rngT) from second row (2) of Target Columns
' Range (rngT) resized by Target Array Rows Count (i).
Set rngT = rngT.Rows(2).Resize(i)
' Copy Target Array (vntT) to Target Range (rngT).
rngT = vntT
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub
SUMIF?! An Excel Solution
This is more a question than an answer:
Could this be regarded as a simplified visual presentation of what you are trying to achieve?
You can use the following formula in cell I2:
=SUMIF(C$2:C$16,H2,G$2:G$16)
Adjust the ranges and copy down.
Advanced Filter Array Loop Solution
Sub SumIfToUnique2() ' Advanced Filter & Loop through Arrays, Add ... 13s
' Name
Const cNsht As Variant = "Sheet2" ' Name Worksheet Name/Index
Const cNrow As Long = 1 ' Name First Row Number
Const cNcol As Long = 3 ' Name Column Number
Const cVcol As Long = 7 ' Value Column Number
' Unique
Const cUsht As Variant = "Sheet2" ' Unique Worksheet Name/Index
Const cUrow As Long = 1 ' Unique First Row Number
Const cUcol As Long = 8 ' Unique Column Number
Const cSumIf As String = "Total" ' SumIf Column Header
Const cUnique As String = "Unique" ' Unique Column Header
Dim rngN As Range ' Name Column Range, Last Used Cell in Name Column,
' Name Range with Headers, Name Range
Dim rngV As Range ' Value Range
Dim rngU As Range ' Unique Column Range, Last Used Cell in Unique Column,
' Unique Range
Dim vntN As Variant ' Name Array
Dim vntV As Variant ' Value Array
Dim vntU As Variant ' Unique Array
Dim vntS As Variant ' SumIf Array
Dim i As Long ' Name/Value Array Row Counter
Dim k As Long ' Unique/SumIf Array Row Counter
Dim strN As String ' Current Name (in Name Array)
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle Errors.
On Error GoTo ErrorHandler
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Create a reference to Name Column Range (rngN) i.e. the range in
' Name Column (cNcol) from Name First Row (cNrow) to the bottom row
' of Name Worksheet (cNsht).
Set rngN = .Resize(.Rows.Count - cNrow + 1).Offset(cNrow - 1)
End With
' In Unique Column
With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
' Create a reference to Unique Column Range (rngU) i.e. the range in
' Unique Column (cUcol) from Unique First Row (cUrow) to the bottom row
' of Unique Worksheet (cUsht).
Set rngU = .Resize(.Rows.Count - cUrow + 1).Offset(cUrow - 1)
End With
' Clear contents of Unique Column Range (rngU).
rngU.ClearContents
' Calculate SumIf Column Range.
' Clear contents of SumIf Column Range.
rngU.Offset(, 1).ClearContents
' Write unique values from Name Column Range (rngN), starting with the
' header (aka title), to Unique Column Range (rngU), starting in its
' First Row (1).
rngN.AdvancedFilter xlFilterCopy, , rngU.Resize(1), True
' Calculate Unique Header Cell Range.
' Write Unique Column Header to Unique Header Cell Range.
rngU.Resize(1) = cUnique
' Calculate SumIf Header Cell Range.
' Write SumIf Column Header to SumIf Header Cell Range.
rngU.Resize(1).Offset(, 1) = cSumIf
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Calculate Last Used Cell in Name Column.
Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Name Range with headers.
Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
End With
' Calculate Name Range (without headers).
Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
' Copy Name Range (rngN) to Name Array (vntN).
vntN = rngN
' Calculate Value Range (without headers).
Set rngV = rngN.Offset(, cVcol - cNcol)
' Copy Value Range (rngV) to Value Array (vntV).
vntV = rngV
' In Unique Column
With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
' Calculate Last Used Cell in Unique Column.
Set rngU = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Unique Range with headers.
Set rngU = .Cells(cUrow).Resize(rngU.Row - cUrow + 1)
End With
' Calculate Unique Range (without headers).
Set rngU = rngU.Resize(rngU.Rows.Count - 1).Offset(1)
' Copy Unique Range (rngU) to Unique Array (vntU).
vntU = rngU
' Resize SumIf Array to size of Unique Array.
ReDim vntS(1 To UBound(vntU), 1 To 1)
' Loop through elements (rows) of Name Array.
For i = 1 To UBound(vntN)
' Write current value in Name Array (vntN) to Current Name (strN).
strN = vntN(i, 1)
' Loop through elements (rows) of Unique/SumIf Array.
For k = 1 To UBound(vntU)
If vntU(k, 1) = strN Then
vntS(k, 1) = vntS(k, 1) + vntV(i, 1)
Exit For
End If
Next
Next
' Calculate SumIf Range (from Unique Range (rngU)).
' Copy SumIf Array to SumIf Range.
rngU.Offset(, 1) = vntS
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub
Advanced Filter SumIf Solution
Sub SumIfToUnique1() ' Advanced Filter & SumIf on Ranges ... 17-22s
' Name
Const cNsht As Variant = "Sheet2" ' Name Worksheet Name/Index
Const cNrow As Long = 1 ' Name First Row Number
Const cNcol As Long = 3 ' Name Column Number
Const cVcol As Long = 7 ' Value Column Number
' Unique
Const cUsht As Variant = "Sheet2" ' Unique Worksheet Name/Index
Const cUrow As Long = 1 ' Unique First Row Number
Const cUcol As Long = 8 ' Unique Column Number
Const cSumIf As String = "Total" ' SumIf Column Header
Const cUnique As String = "Unique" ' Unique Column Header
Dim rngN As Range ' Name Column Range, Last Used Cell in Name Column,
' Name Range with Headers, Name Range
Dim rngV As Range ' Value Range
Dim rngU As Range ' Unique Column Range, Last Used Cell in Unique Column,
' Unique Range
Dim vntU As Variant ' Unique Array
Dim vntS As Variant ' SumIf Array
Dim i As Long ' Unique Array Row Counter
' Speed up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Handle Errors.
On Error GoTo ErrorHandler
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Create a reference to Name Column Range (rngN) i.e. the range in
' Name Column (cNcol) from Name First Row (cNrow) to the bottom row
' of Name Worksheet (cNsht).
Set rngN = .Resize(.Rows.Count - cNrow + 1).Offset(cNrow - 1)
End With
' In Unique Column
With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
' Create a reference to Unique Column Range (rngU) i.e. the range in
' Unique Column (cUcol) from Unique First Row (cUrow) to the bottom row
' of Unique Worksheet (cUsht).
Set rngU = .Resize(.Rows.Count - cUrow + 1).Offset(cUrow - 1)
End With
' Clear contents of Unique Column Range (rngU).
rngU.ClearContents
' Calculate SumIf Column Range.
' Clear contents of SumIf Column Range.
rngU.Offset(, 1).ClearContents
' Write unique values from Name Column Range (rngN), starting with the
' header (aka title), to Unique Column Range (rngU), starting in its
' First Row (1).
rngN.AdvancedFilter xlFilterCopy, , rngU.Resize(1), True
' Calculate Unique Header Cell Range.
' Write Unique Column Header to Unique Header Cell Range.
rngU.Resize(1) = cUnique
' Calculate SumIf Header Cell Range.
' Write SumIf Column Header to SumIf Header Cell Range.
rngU.Resize(1).Offset(, 1) = cSumIf
' In Name Column
With ThisWorkbook.Worksheets(cNsht).Columns(cNcol)
' Calculate Last Used Cell in Name Column.
Set rngN = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Name Range with headers.
Set rngN = .Cells(cNrow).Resize(rngN.Row - cNrow + 1)
End With
' Calculate Name Range (without headers).
Set rngN = rngN.Resize(rngN.Rows.Count - 1).Offset(1)
' Calculate Value Range (without headers).
Set rngV = rngN.Offset(, cVcol - cNcol)
' In Unique Column
With ThisWorkbook.Worksheets(cUsht).Columns(cUcol)
' Calculate Last Used Cell in Unique Column.
Set rngU = .find("*", , xlFormulas, , xlByColumns, xlPrevious)
' Calculate Unique Range with headers.
Set rngU = .Cells(cUrow).Resize(rngU.Row - cUrow + 1)
End With
' Calculate Unique Range (without headers).
Set rngU = rngU.Resize(rngU.Rows.Count - 1).Offset(1)
' Copy Unique Range to Unique Array.
vntU = rngU
' Resize SumIf Array to size of Unique Array.
ReDim vntS(1 To UBound(vntU), 1 To 1)
' Loop through elements (rows) of SumIf/Unique Array.
For i = 1 To UBound(vntS)
' Write result of SumIf funtion to current element (row) of SumIf Array.
vntS(i, 1) = WorksheetFunction.SumIf(rngN, vntU(i, 1), rngV)
Next
' Calculate SumIf Range (from Unique Range (rngU)).
' Copy SumIf Array to SumIf Range.
rngU.Offset(, 1) = vntS
ProcedureExit:
' Speed down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
ErrorHandler:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub
I'm trying to create array with values from non-empty cells in range B6:B183 . array_articles = ActiveWorsheet.Range("B6:B183") return empty array, so I'm trying to do this:
Sub set_price()
Dim articul_price() As String
Dim articul_bill As String
Dim counter As Integer
Dim array_articles() As Variant
Dim array_unsorted() As String
Dim cell As Range
counter = 0
ReDim articul_price(0)
For Each cell In ActiveWorsheet.Range("B6:B183") ' error 424 Object required
If IsEmpty(cell.Value) Then
array_unsorted(counter) = cell.Value
ReDim Preserve array_unsorted(counter)
Else
'do nothing
counter = counter + 1
End If
Next
End Sub
This code return
error 424 Object required
To easily load a range into an array (without a loop) use:
Dim array_unsorted As Variant 'must be variant!
array_unsorted = ThisWorkbook.Worksheets("NameOfSheet").Range("B6:B183").Value '2-dimensional array
you can access the array with
Debug.Print array_unsorted(row, column) 'yes it has only 1 column but it is still there
Debug.Print array_unsorted(1, 1) 'first value
Debug.Print array_unsorted(2, 1) 'second value
or transpose it to make it 1-dimensional
array_unsorted = WorksheetFunction.Transpose(ThisWorkbook.Worksheets("NameOfSheet").Range("B6:B183").Value) '1-dimensional
and you can access the array with
Debug.Print array_unsorted(i) 'this is 1-dimensional
Debug.Print array_unsorted(1) 'first value
Debug.Print array_unsorted(2) 'second value
Note that the transpose function has a limit of 65,536 rows. If you exceed them the rest will be truncated silently.
I recommend to avoid ActiveWorksheet (unless you write an add-in or the code is used for multiple worksheets). Use ThisWorkbook.Worksheets("NameOfSheet") to reference the worksheet by its name, which is more save and Excel won't run into errors.