does anyone know why this range(c) doesnt work? i am looping through a row and filtering a table with c as a criteria, after that i need to paste everything this filter give me under the c cell.
Sub exercicio1()
Dim table As Range
For Each c In Range("i5", Range("i5").End(xlToRight))
Range("B5").Select
Selection.AutoFilter
ActiveSheet.Range("$B$5:$C$5570").AutoFilter Field:=1, Criteria1:=c
Range("C6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Range("$B$5:$C$5570").AutoFilter Field:=1
Range(c).Offset(1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next c
End Sub
i want to select the cell under c
As the earlier answer "c" is already a range...
SO:
c.Offset(1).Select
Return Lookup in Columns Using Application.Match
Adjust the values in the constant section.
Option Explicit
Sub ReturnLookupInColumns()
' Define constants.
' Source (lookup and read)
Const slCol As String = "B"
Const svCol As String = "C"
Const sfRow As Long = 6
' Destination (lookup and write)
Const dfCol As String = "I"
Const dlRow As Long = 5
' Reference the worksheet ('ws')...
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' ... and write its number of rows to a variable ('wsrCount').
Dim wsrCount As Long: wsrCount = ws.Rows.Count
' Using the source lookup column ('slCol'), calculate the last row
' ('slRow'), the row of the last non-empty cell in the column.
Dim slRow As Long: slRow = ws.Cells(wsrCount, slCol).End(xlUp).Row
' Reference the (one-column) source lookup range ('slrg').
Dim slrg As Range
Set slrg = ws.Range(ws.Cells(sfRow, slCol), ws.Cells(slRow, slCol))
' Using 'EntireRow' and 'Resize' on the source lookup range,
' reference the (one-column) source value range ('svrg').
Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol)
' Using the destination lookup row ('dlRow'), calculate the last column
' ('dlCol'), the column of the last non-empty cell in the row.
Dim dlCol As Long
dlCol = ws.Cells(dlRow, ws.Columns.Count).End(xlToLeft).Column
' Reference the (one-row) destination lookup range ('dlrg').
Dim dlrg As Range
Set dlrg = ws.Range(ws.Cells(dlRow, dfCol), ws.Cells(dlRow, dlCol))
' Clear the contents below the destination lookup range.
dlrg.Offset(1).Resize(wsrCount - dlrg.Row).ClearContents
' To avoid an inner loop (increase efficiency), use this little known
' feature of 'Application.Match' that will return the destination indexes
' (in this case the destination column indexes) of the matching values
' of the source lookup range, in a 2D one-based (one-column) array
' ('dIndexes'). If a source value is not found, the element
' at the same position in the array will contain an error value
' ('Error 2042').
Dim dIndexes As Variant: dIndexes = Application.Match(slrg, dlrg, 0)
' Declare additional variables used in the loop.
Dim svCell As Range ' Current Source Value Cell
Dim sr As Long ' Current Row of the Source Ranges
Dim dvCell As Range ' Current Destination Value Cell
Dim dIndex As Variant ' Current Index in the Destination Indexes Array
' Firstly, 'dIndex' needs to be declared as variant because it will
' be assigned a number or an error value.
' Secondly, 'dIndex' needs to be declared as variant because it will
' be used as a so-called 'For Each control variable' which needs
' to be declared as variant (or as object) no matter what.
' Loop through the elements in the destination indexes array.
For Each dIndex In dIndexes
' Since the destination indexes array has the same number of elements
' as the source ranges have rows and the array is one-based,
' this number ('sr') also represents the current element's index,
' the row position in the array (see 'dIndexes(sr, 1)' the line after).
sr = sr + 1
' Check if the current source lookup value was found.
If IsNumeric(dIndexes(sr, 1)) Then ' source lookup value was found
' Reference the current source value cell.
Set svCell = svrg.Cells(sr)
' Reference the current destination value cell.
Set dvCell = ws.Cells(wsrCount, dlrg.Columns(dIndex).Column) _
.End(xlUp).Offset(1)
' Write the value from the current source value cell
' to the current destination value cell.
dvCell.Value = svCell.Value
'Else ' source lookup value was not found; do nothing
End If
Next dIndex
' Inform to not wonder if the code has run or not.
MsgBox "Lookup has finished.", vbInformation
End Sub
Related
I am trying to pass a range of columns as a parameter for a function.
For sr = 1 To srCount
If IsEmpty(Data(sr, 4)) Then
dr = dr + 1
Data(dr, 4) = Data(sr, 1) 'instead of just the first column, a range of columns
End If
Next sr
I thought I could define a range ("A:C") and pass its reference as a parameter, but VBA doesn't seem to accept anything but (references to) long variables/constants as parameters for the Data() function. What is the correct syntax for such a thing?
Edited 01/26 for clarification: Data is an array. The goal is to copy a row of a range of columns based on the condition that another cell in that row is empty (If IsEmpty(Data(sr, 4))). E.g. if cell(7,4) is empty, then row 7 of columns A-C should be copied to another area of the worksheet (K2:M2). If (13,4) is empty, then row 13, columns A-C to K3-M3, and so on.
As per #Cameron's tip I used Collections to store the ranges instead.
Dim users As New Collection
Dim cell As Range
With Worksheets(2)
users.Add .Range("A:C"), "Users"
users.Add .Range("K:M"), "FinalList"
End With
For Each cell In users.Item("Users")
For sr = 1 to srCount
If IsEmpty(Data(sr, 4)) Then
dr = dr + 1
FinalList = Users
End If
Next sr
Next
Despite the research I can't find how I can manipulate Collections for this objective. Once I have all the necessary values stored in FinalList, how can I copy them to the goal Range ("K:M")?
Using a Single Array to Extract Matching Data
Option Explicit
Sub Test()
Const SRC_CRITERIA_COLUMN As Long = 4
Const DST_WORKSHEET_ID As Variant = 2 ' using the tab name is preferable!
Const DST_FIRST_CELL As String = "K2"
' The following could be calculated from the source variables.
Const DST_COLUMNS_COUNT As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' whatever...
Dim Data() ' ?
Dim srCount As Long ' ?
' whatever...
Dim sr As Long, dr As Long, c As Long
' Write the matching values to the top of the array
' When using a single array, the result needs to be in the top-left
' of the array. The data of interest is already left-most
' so there is no column offset.
For sr = 1 To srCount
If IsEmpty(Data(sr, SRC_CRITERIA_COLUMN)) Then
dr = dr + 1
For c = 1 To DST_COLUMNS_COUNT
Data(dr, c) = Data(sr, c)
Next c
End If
Next sr
' Reference the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(DST_WORKSHEET_ID)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
' Note how you're using just the 'dr' number of rows
' and 'DST_COLUMNS_COUNT' number of columns.
Dim drg As Range: Set drg = dfCell.Resize(dr, DST_COLUMNS_COUNT)
' Write the result from the top-left of the array to the destination range.
drg.Value = Data
' Clear below.
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).ClearContents
MsgBox "Data copied.", vbInformation
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
I am trying to copy data from one worksheet to another based on the column-name. In the source worksheet, the data starts at A1. In the destination worksheet, the data should be pasted at row A11 and not A1. If I used EntireColumn.Copy I get an error about the source and destination copy area not being the same. I came across the UsedRange property but I am unbale to apply it to my scenario
For Each columnName In allColumns
'call a function to get the column to copy
If columnToCopy > 0 Then
columnName.Offset(1, 0).EntireColumn.Copy Destination:=ws2.Cells(11, columnToCopy)
End If
Next
In the above snippet, In dont want to use 'EntireColumn'. I only want the columns that have data. The variable columnName is for example 'Person ID'
What is the best way to do this?
Thanks.
This would be a typical approach:
For Each ColumnName In allColumns
If columnToCopy > 0 Then
With ColumnName.Parent
.Range(ColumnName.Offset(1, 0), .Cells(.Rows.Count, ColumnName.Column).End(xlUp)).Copy _
Destination:=ws2.Cells(11, columnToCopy)
End With
End If
Next
Assumes allColumns is a collection of single-cell ranges/column headers.
Copy/Paste Column
There is not enough information to give an accurate answer so here is a scenario you might consider studying.
The Code
Option Explicit
Sub TESTdetermineColumnNumber()
' Define constants. Should be more.
' Define Criteria.
Const Criteria As String = "Total"
' Define Header Row.
Const hRow As Long = 1
' Define Copy Range (Column Range)
' Define Source Worksheet.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
' Define Header Row Range.
Dim RowRange As Range
Set RowRange = ws.Rows(hRow)
' Determine Column Number.
Dim ColumnNumber As Long
ColumnNumber = determineColumnNumber(RowRange, Criteria)
' Validate Column Number.
If ColumnNumber = 0 Then
Exit Sub
End If
' Determine Last Row.
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, ColumnNumber).End(xlUp).Row
' Define First Data Row Number.
Dim FirstRow As Long
FirstRow = hRow + 1
' Define Column Range.
Dim ColumnRange As Range
Set ColumnRange = ws.Cells(FirstRow, ColumnNumber) _
.Resize(LastRow - FirstRow + 1)
' Define Paste Range.
' Define Destination Worksheet.
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
' Define Destination Column.
Dim columnToCopy As Long
columnToCopy = 2
' Define Paste Range.
Dim PasteRange As Range
Set PasteRange = ws2.Cells(11, columnToCopy)
' Copy/Paste.
' Copy values, formulas and formats.
ColumnRange.Copy Destination:=PasteRange
' It is more efficient if you need only values to use the following:
PasteRange.Resize(ColumnRange.Rows.Count).Value = ColumnRange.Value
End Sub
Function determineColumnNumber(RowRange As Range, _
Criteria As String) _
As Long
Dim Temp As Variant
Temp = Application.Match(Criteria, RowRange, 0)
If Not IsError(Temp) Then
determineColumnNumber = Temp
End If
End Function
My data sheet ("srData") is a pivot table that is filled using a userform. All data have a unique ID in column A of the data sheet. In the userform checkboxes are selected, which will change the cells, in columns K:AB, interior color to white(2), else interior color is grey(15)
In my main worksheet ("Formulier"), based on the value of a drop down box (C6)where the unique ID is selected (i.e. SR-1, SR-2,SR-3 etc...), the headers from sheet("srData") are returned in column A of sheet("Formulier") starting from row 20 if the interior.colorindex=2. The values in the cells are returned in column D starting from row 20.
Now in Column Y and Z of ("srData") I have placed a hyperlink which links to a PDF.(see SR-4 first image) In column Y and Z there will allways be hyperlinks in the cells with interior.colorindex=2.
When I now select the unique ID from the dropdown on sheet("Formulier") I would like it to return an active hyperlink and not just tekst as it does now. Is this possible?
This is the code I have for returning the header and the values. The code was created by VBasic2008 so credit goes to him.
`
Option Explicit
Public Const CriteriaCell As String = "C6" ' Criteria Cell Range Address
Sub ColorSearch()
' Source
Const cSource As Variant = "srData" ' Worksheet Name/Index
Const cCriteriaColumn As Variant = "A" ' Criteria Column Letter/Number
Const cColumns As String = "K:AB" ' Columns Range Address
Const cHeaderRow As Long = 1 ' Header Row Number
Const cColorIndex As Long = 2 ' Criteria Color Index (2-White)
' Target
Const cTarget As Variant = "Formulier" ' Worksheet Name/Index
Const cFr As Long = 20 ' First Row Number
Const cCol As Variant = "A" ' Column Letter/Number
Const cColVal As Variant = "D" ' Value Column Letter/Number
Dim Rng As Range ' Source Found Cell Range
Dim vntH As Variant ' Header Array
Dim vntC As Variant ' Color Array
Dim vntV As Variant ' Value Array
Dim vntT As Variant ' Target Array
Dim vntTV As Variant ' Target Value Array
Dim i As Long ' Source/Color Array Column Counter
Dim k As Long ' Target Array Row Counter
Dim sRow As Long ' Color Row
Dim SVal As String ' Search Value
Dim Noe As Long ' Source Number of Elements
' Write value from Criteria Cell Range to Search Value.
SVal = ThisWorkbook.Worksheets(cTarget).Range(CriteriaCell)
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource)
' Search for Search Value in Source Criteria Column and create
' a reference to Source Found Cell Range.
Set Rng = .Columns(cCriteriaColumn) _
.Find(SVal, , xlValues, xlWhole, , xlNext)
' Check if Search Value not found. Exit if.
If Rng Is Nothing Then Exit Sub
' Write row of Source Found Cell Range to Color Row.
sRow = Rng.Row
' Release rng variable (not needed anymore).
Set Rng = Nothing
' In Source Columns
With .Columns(cColumns)
' Copy Header Range to Header Array.
vntH = .Rows(cHeaderRow)
' Copy Color Range to Color Array.
vntC = .Rows(sRow)
' *** Copy Color Range to Value Array.
' Note: The values are also written to Color Array, but are
' later overwritten with the Color Indexes.
vntV = .Rows(sRow)
' Write number of columns in Source Columns to Source Number
' of Elements.
Noe = .Columns.Count
' Loop through columns of Color Range/Array.
For i = 1 To Noe
' Write current ColorIndex of Color Range to current
' element in Color Array.
vntC(1, i) = .Cells(sRow, i).Interior.ColorIndex
Next
End With
End With
' Resize Target Array to Number of Elements rows and one column.
ReDim vntT(1 To Noe, 1 To 1)
' *** Resize Target Value Array to Number of Elements rows and one column.
ReDim vntTV(1 To Noe, 1 To 1)
' Loop through columns of Color Array.
For i = 1 To Noe
' Check if current value in Color Array is equal to Criteria
' Column Index.
If vntC(1, i) = cColorIndex Then
' Count row in Target Array.
k = k + 1
' Write value of current COLUMN in Header Array to
' element in current ROW of Target Array.
vntT(k, 1) = vntH(1, i)
' *** Write value of current COLUMN in Value Array to
' element in current ROW of Target Value Array.
vntTV(k, 1) = vntV(1, i)
End If
Next
' Erase Header and Color Arrays (not needed anymore).
Erase vntH
Erase vntC
Erase vntV '***
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget)
' Calculate Target Range by resizing the cell at the intersection of
' Target First Row and Target Column, by Number of Elements.
' Copy Target Array to Target Range.
.Cells(cFr, cCol).Resize(Noe) = vntT
' *** Calculate Target Value Range by resizing the cell at the
' intersection of Target First Row and Value Column, by Number of
' Elements.
' Copy Target Value Array to Target Value Range.
.Cells(cFr, cColVal).Resize(Noe) = vntTV
End With
End Sub
`
Make a backup before and give this a try:
Option Explicit
Public Const CriteriaCell As String = "C6" ' Criteria Cell Range Address
Sub ColorSearch()
' Source
Const cSource As Variant = "srData" ' Worksheet Name/Index
Const cCriteriaColumn As Variant = "A" ' Criteria Column Letter/Number
Const cColumns As String = "K:AB" ' Columns Range Address
Const cHeaderRow As Long = 1 ' Header Row Number
Const cColorIndex As Long = 2 ' Criteria Color Index (2-White)
' Target
Const cTarget As Variant = "Formulier" ' Worksheet Name/Index
Const cFr As Long = 20 ' First Row Number
Const cCol As Variant = "A" ' Column Letter/Number
Const cColVal As Variant = "D" ' Value Column Letter/Number
Dim Rng As Range ' Source Found Cell Range
Dim targetCell As Range ' Cell to add hyperlink
Dim vntH As Variant ' Header Array
Dim vntC As Variant ' Color Array
Dim vntV As Variant ' Value Array
Dim vntHy As Variant ' Hyperlink Array (*)
Dim vntT As Variant ' Target Array
Dim vntTV As Variant ' Target Value Array
Dim vntTH As Variant ' Target Hyperlink
Dim i As Long ' Source/Color Array Column Counter
Dim k As Long ' Target Array Row Counter
Dim sRow As Long ' Color Row
Dim SVal As String ' Search Value
Dim Noe As Long ' Source Number of Elements
Dim hyperlinkCounter As Long ' Counter for assigning hyperlink
' Write value from Criteria Cell Range to Search Value.
SVal = ThisWorkbook.Worksheets(cTarget).Range(CriteriaCell)
' In Source Worksheet
With ThisWorkbook.Worksheets(cSource)
' Search for Search Value in Source Criteria Column and create
' a reference to Source Found Cell Range.
Set Rng = .Columns(cCriteriaColumn) _
.Find(SVal, , xlValues, xlWhole, , xlNext)
' Check if Search Value not found. Exit if.
If Rng Is Nothing Then Exit Sub
' Write row of Source Found Cell Range to Color Row.
sRow = Rng.Row
' Release rng variable (not needed anymore).
Set Rng = Nothing
' In Source Columns
With .Columns(cColumns)
' Copy Header Range to Header Array.
vntH = .Rows(cHeaderRow)
' Copy Color Range to Color Array.
vntC = .Rows(sRow)
' *** Copy Color Range to Value Array.
' Note: The values are also written to Color Array, but are
' later overwritten with the Color Indexes.
vntV = .Rows(sRow)
' Write number of columns in Source Columns to Source Number
' of Elements.
Noe = .Columns.Count
' Redimension
ReDim vntHy(1 To 1, 1 To Noe)
' Loop through columns of Color Range/Array.
For i = 1 To Noe
' Write current ColorIndex of Color Range to current
' element in Color Array.
vntC(1, i) = .Cells(sRow, i).Interior.ColorIndex
If .Cells(sRow, i).Hyperlinks.Count > 0 Then
vntHy(1, i) = .Cells(sRow, i).Hyperlinks(1).Address
End If
Next
End With
End With
' Resize Target Array to Number of Elements rows and one column.
ReDim vntT(1 To Noe, 1 To 1)
' *** Resize Target Value Array to Number of Elements rows and one column.
ReDim vntTV(1 To Noe, 1 To 1)
' Resize target hyperlink array
ReDim vntTH(1 To Noe, 1 To 1)
' Loop through columns of Color Array.
For i = 1 To Noe
' Check if current value in Color Array is equal to Criteria
' Column Index.
If vntC(1, i) = cColorIndex Then
' Count row in Target Array.
k = k + 1
' Write value of current COLUMN in Header Array to
' element in current ROW of Target Array.
vntT(k, 1) = vntH(1, i)
' *** Write value of current COLUMN in Value Array to
' element in current ROW of Target Value Array.
vntTV(k, 1) = vntV(1, i)
' Add hyperlink to array
vntTH(k, 1) = vntHy(1, i)
End If
Next
' Erase Header and Color Arrays (not needed anymore).
Erase vntH
Erase vntC
Erase vntV '***
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget)
' Calculate Target Range by resizing the cell at the intersection of
' Target First Row and Target Column, by Number of Elements.
' Copy Target Array to Target Range.
.Cells(cFr, cCol).Resize(Noe) = vntT
' *** Calculate Target Value Range by resizing the cell at the
' intersection of Target First Row and Value Column, by Number of
' Elements.
' Copy Target Value Array to Target Value Range.
.Cells(cFr, cColVal).Resize(Noe) = vntTV
' Assign hyperlinks to cells
For Each targetCell In .Cells(cFr, cColVal).Resize(Noe)
' Remove previous hyperlinks
If targetCell.Hyperlinks.Count > 0 Then
targetCell.Hyperlinks.Item(1).Delete
End If
' Add new hyperlink
If vntTH(hyperlinkCounter + 1, 1) <> vbNullString Then
ThisWorkbook.Worksheets(cTarget).Hyperlinks.Add targetCell, vntTH(hyperlinkCounter + 1, 1)
End If
hyperlinkCounter = hyperlinkCounter + 1
Next targetCell
End With
End Sub
In general, the way you can turn a string to a Hyperlink is the following:
Sub text2Hyperlink()
Dim sht As Worksheet
Dim URL As String
Dim filePath As String
Set sht = ThisWorkbook.Worksheets("Worksheet Name") ' whichever worksheet you're working with
filePath = ".....\Something.pdf"
URL = "https://www.google.com/"
sht.Hyperlinks.Add sht.Range("A1"), filePath
sht.Hyperlinks.Add sht.Range("A2"), URL
End Sub
This takes some text stored in a string, and assigns it as a hyperlink in a cell. It works both for websites and files
In this case you end up with a link to a file in cell A1 and with a link to a webpage in cell A2.
You can modify this to suit your needs.
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