I have a problem with number formatting in my code.
If I stop the macro at this subroutine and run it step by step (F8) it works fine, no issues. However, if it's run as a whole with the rest of the macro (won't post the whole thing as it's quite huge) it just doesn't apply the number formatting and I can't seem to figure out why.
Any help would be appreciated, thanks!
Code:
Private Sub VolumeIncluded(TWs As Worksheet, MWs2 As Worksheet, MLngth As Double, MFinal As String, TLnght As Double, TFinal As String)
Dim TFtLnght As Double
On Error GoTo NextSheet
TLnght = TWs.Range("$A$" & Rows.Count).End(xlUp).Offset(2).Row
TFinal = "$A$" & TLnght
TWs.Range(TFinal) = "Volume Included"
With TWs.Range(TFinal)
.Interior.Color = 12611584
.Font.ThemeColor = xlThemeColorDark1
.Font.Bold = True
End With
MLngth = MWs2.Range("$H$" & Rows.Count).End(xlUp).Row
MFinal = "$A$16:$H" & MLngth
MWs2.Range(MFinal).Copy
TLnght = TWs.Range("$A$" & Rows.Count).End(xlUp).Offset(1).Row
TFinal = "$A$" & TLnght
TFormat = "$H$" & TLnght
TWs.Range(TFinal).PasteSpecial xlPasteAllUsingSourceTheme
Application.CutCopyMode = False
'----------This piece doesn't work-----------
TFtLnght = TWs.Range("$H$" & Rows.Count).End(xlUp).Row
TFinal = "$H$" & TLnght & ":" & "$H$" & TFtLnght
Range(TFinal).NumberFormat = "#,##0"
NextSheet:
End Sub
TWs.Range(TFinal).NumberFormat = "#,##0"
When you call Range() it's always safe to reference from a worksheet object that you know, since the active worksheet is used by default.
Related
I'm trying to copy the values and conditional formatting from a column in the sheet wsHR and paste them into wsHH.
With the code below the values are pasted, but the formatting is not.
I added formatting into wsHR that isn't conditional, and it works fine copying that over.
Is there a way to paste conditional formatting?
Private Sub CommandButton1_Click()
'Set variables
Dim LastRow As Long
Dim wsHR As Worksheet
Dim wsHH As Worksheet
Dim y As Integer
'Set row value
y = 4
'Set heavy chain raw data worksheet
Set wsHR = ThisWorkbook.Worksheets(4)
'Set heavy chain hits worksheet
Set wsHH = ThisWorkbook.Worksheets(6)
'Optimizes Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Finds last row
With wsHR
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Iterates through rows in column A, and copies the row into proper sheet depending on "X" in PBS/KREBS
For i = 4 To LastRow
'Checks for "X" in PBS
If VarType(wsHR.Range("AD" & i)) = 8 Then
If wsHR.Range("AD" & i).Value = "X" Or wsHR.Range("AE" & i).Value = "X" Then
With wsHH
wsHR.Range("A" & i).Copy
.Range("A" & y).PasteSpecial Paste:=xlPasteFormats
.Range("A" & y).PasteSpecial Paste:=xlPasteValues
'Range before PBS/KREBS
.Range("B" & y & ":AC" & y).Value = wsHR.Range("B" & i & ":AC" & i).Value
'Adds space to keep formulas for PBS/KREBS
'Range after PBS/KREBS
.Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value
End With
y = y + 1
End If
End If
Next i
'Message Box when tasks are completed
MsgBox "Complete"
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I cannot use the same conditional formatting rules in the second sheet, wsHH, because not all of the values from wsHR are pasted. The conditional formatting is based on duplicates.
Found a work-around to get the formatting. Previously, you were not able to access the interior color from conditional formatting in VBA without going through a lot of extra work (see here). However, I discovered as of Excel 2010, this was changed (see here). Since I'm using Excel 2013, I am able to use .DisplayFormat to find the interior color regardless of formatting (see here).
Using this, I changed:
With wsHH
wsHR.Range("A" & i).Copy
.Range("A" & y).PasteSpecial Paste:=xlPasteFormats
.Range("A" & y).PasteSpecial Paste:=xlPasteValues
'Range before PBS/KREBS
.Range("B" & y & ":AC" & y).Value = wsHR.Range("B" & i & ":AC" & i).Value
'Adds space to keep formulas for PBS/KREBS
'Range after PBS/KREBS
.Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value
End With
to this:
With wsHH
'Range before PBS/KREBS
.Range("A" & y & ":AC" & y).Value = wsHR.Range("A" & i & ":AC" & i).Value
'Adds space to keep formulas for PBS/KREBS
'Applying background CF color to new sheet
If wsHR.Range("A" & i).DisplayFormat.Interior.ColorIndex > 0 Then
.Range("A" & y).Interior.ColorIndex = 3
End If
'Range after PBS/KREBS
.Range("AG" & y & ":AW" & y).Value = wsHR.Range("AG" & i & ":AW" & i).Value
End With
I am no longer copying and pasting values. Instead, I set the values using .Value like I had been for the other cells in the row, and then use the outcome of If wsHR.Range("A" & i).DisplayFormat.Interior.ColorIndex > 0 Then to determine if the second sheet's cell should be formatted.
I wrote some more complete and customizable/parameterized copy subs to complete this task in a quite performant way. So one can decide if things like the following should be copied or not:
border styles
font styles
background color (foreground is always copied)
text wrapping
horizontal and/or vertical alignment
normal paste operation with its XlPasteType and XlPasteSpecialOperation params
by default enabled and copying the values and number formats
which would not copy conditional formatting styles applied
general example usage of custom subs below
e.g. the following call:
EventsDisable
PasteWithDisplayFormat Range("B40"), Range("A1:Z30")
EventsEnable
OP query example
in the OP example it should be something like this:
With wsHH
PasteWithDisplayFormat .Range("A" & y), wsHR.Range("A" & i)
'...
End With
instead of:
With wsHH
wsHR.Range("A" & i).Copy
.Range("A" & y).PasteSpecial Paste:=xlPasteFormats
.Range("A" & y).PasteSpecial Paste:=xlPasteValues
'...
End With
custom subs
(please feel free to enhance/extend it here for others)
'including conditional formatting as fixed styles (DisplayFormat)
'based on Range.PasteSpecial
Public Sub PasteWithDisplayFormat( _
dst As Range, _
Optional src As Range, _
Optional pasteSpecialBefore As Boolean = True, _
Optional paste As XlPasteType = xlPasteValuesAndNumberFormats, _
Optional Operation As XlPasteSpecialOperation = xlNone, _
Optional SkipBlanks As Boolean = False, _
Optional Transpose As Boolean = False, _
Optional Borders As Boolean = True, _
Optional Font As Boolean = True, _
Optional InteriorColor As Boolean = True, _
Optional WrapText As Boolean = True, _
Optional HorizontalAlignment As Boolean = True, _
Optional VerticalAlignment As Boolean = True _
)
If src Is Nothing Then Set src = Selection
If pasteSpecialBefore Then dst.PasteSpecial paste:=paste, Operation:=Operation, SkipBlanks:=False, Transpose:=False
Dim x As Integer: For x = 1 To src.Rows.Count
For y = 1 To src.Columns.Count
Dim sf As DisplayFormat: Set sf = src.Cells(x, y).DisplayFormat 'source cells DisplayFormat
With dst.Cells(x, y)
If Borders Then CopyBorders .Borders, sf.Borders
If Font Then
.Font.ColorIndex = sf.Font.ColorIndex
.Font.Color = sf.Font.Color
.Font.Background = sf.Font.Background
.Font.FontStyle = sf.Font.FontStyle '=> bold + italic
'.Font.Bold = sf.Font.Bold
'.Font.Italic = sf.Font.Italic
.Font.Size = sf.Font.Size
.Font.Name = sf.Font.Name
End If
If InteriorColor Then .Interior.Color = sf.Interior.Color
If WrapText Then .WrapText = sf.WrapText
If HorizontalAlignment Then .HorizontalAlignment = sf.HorizontalAlignment
If VerticalAlignment Then .VerticalAlignment = sf.VerticalAlignment
End With
Next y
Next x
End Sub
Sub CopyBorders(dst As Borders, src As Borders)
If src.LineStyle <> xlLineStyleNone Then
dst.ColorIndex = src.ColorIndex
If src.ColorIndex <> 0 Then dst.Color = src.Color
dst.Weight = src.Weight
dst.LineStyle = src.LineStyle
dst.TintAndShade = src.TintAndShade
End If
Dim bi As Integer: For bi = 1 To src.Count 'border index
CopyBorder dst(bi), src(bi)
Next bi
End Sub
Sub CopyBorder(dst As Border, src As Border)
If src.LineStyle <> xlLineStyleNone Then
dst.ColorIndex = src.ColorIndex
If src.ColorIndex <> 0 Then dst.Color = src.Color
dst.Weight = src.Weight
dst.LineStyle = src.LineStyle
dst.TintAndShade = src.TintAndShade
End If
End Sub
'used with EventsEnable()
Sub EventsDisable()
With Application: .EnableEvents = False: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With
End Sub
'used with EventsDisable()
Sub EventsEnable()
With Application: .EnableEvents = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With
End Sub
Other approaches found
temp MS Word doc approach
here is one example based on copying to a temp word file and pasting back, but (at least on more complex tables) results in the pasting of some OLE embedded object that is not really usable in excel anymore, but could suffice for other uses:
https://www.ozgrid.com/forum/forum/help-forums/excel-general/119606-copy-colors-but-not-conditional-formating?p=1059236#post1059236
xlPasteAllMergingConditionalFormats
using xlPasteAllMergingConditionalFormats as the XlPasteType seems to produce the same result like the temp MS Word doc approach above
I'm trying to use Excel VBA to pull an entire webpage (a news story) into a single cell. The problem is, when Excel outputs the website, every new line in the source text is placed in a new row. I'd like to know how to output it into one cell.
I have tried many methods, but they don't work because my version of Excel doesn't come with certain libraries? (My knowledge of computer science is limited.) I'm using a 2015 version of Excel on OS X. That's what I'm working with. The eventual goal of this whole project is for Excel to search a whole list of websites (a column of URLs) for a single term (stored in M5 right now), and output YES or NO which of the sites contain that term. For now, I'm trying it out on a single URL stored in E12.
Sub SearchSite()
strsearch = Range("M5")
theurl = Range("E12")
With ActiveSheet.QueryTables.Add(Connection:="URL;" & theurl, Destination:=Range("P1"))
.Name = "NewsQuery"
.AdjustColumnWidth = False
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=True
End With
Debug.Print "DONE"
End Sub
As I mentioned, perahps it's better to keep them all in separate rows. However, if you do need them to be in one cell only, you can use a second Sub to do so:
Sub combineCellsIntoOne(dest As Range)
Dim lastRow As Long
lastRow = Cells(Rows.Count, dest.Column).End(xlUp).Row
Dim i As Long
For i = dest.Row + 1 To lastRow
dest.Value = dest.Value & " " & Cells(i, dest.Column).Value
Cells(i, dest.Column).ClearContents
Next i
End Sub
You can put combineCellsIntoOne Range("P1") after the End With in your original one. That should work (note to change the destination range if/as necessary).
Here's what I ended up doing. The URLs are stored in Column E.
Public strsearch As String
Sub SearchSite()
For j = Selection.Row To Selection.Row + Selection.Rows.count - 1
' Get the URL
theurl = Range("E" & j)
If theurl = "" Then GoTo NextRow
' Fill the Query Table
With ActiveSheet.QueryTables.Add(Connection:="URL;" & theurl, Destination:=Range("P1"))
.Name = "NewsQuery"
.AdjustColumnWidth = False
.RefreshStyle = xlOverwriteCells
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=False
.SaveData = False
End With
' Search the Query Table for the Search Term
strsearch = Range("M5")
bottomrow = Range("P" & Rows.count).End(xlUp).Row
For i = 1 To bottomrow
If InStr(Range("P" & i), strsearch) <> 0 Then
Range("K" & j) = "YES"
Exit For
End If
Range("K" & j) = "NO"
Next i
NextRow:
Next j
End Sub
This should do what you want.
'Import Everything From a Web Page:
Sub Test()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = True
.Navigate "http://finance.yahoo.com" ' should work for any URL
Do Until .ReadyState = 4: DoEvents: Loop
Range("A1").Value = .document.body.innertext
.Quit
End With
End Sub
I'm trying to use .clearcontents on range that is referenced by with some .offset, and I'm having trouble
I know that this works
Sub clear1_1()
Workbooks("xyz").Sheets("abc").range("A2:A3").ClearContents
End Sub
but if I try this it does not
Sub clear2()
Dim region As range
Set region = range("S509:AD618")
Workbooks("xyz").Worksheets("abc").range(region).ClearContents
end sub
I do understand from other postings, that it has something to do with object defyining, but I have no idea where I do mistake, what I need to write.
Final macro is run from one workbook, and is supposed to .clearcontents in other not activated workbook.
My code looks like this
sub Macro()
..... ton of code
Dim filename as string
dim sheetname as string
dim address3, address4 as string
filename = "xyz"
sheetname = "abc" ' both variables that are loaded in other part
address3 and address4 loaded in other part
'here is where i get the error
sheets(sheetname).Range(Range(address3).Offset(0, 12).Address & ":" & Range(address4).Offset(-1, 23)).ClearContents
end sub
I can probably bypass it with .value=""
But I'm looking to learn. Thank you for any response in advance.
EDIT 1
Hi Scott, doesn't make it. Posting bigger part of my code
If mapanchorsuccess = True And map1success = True And map2success = True Then
If Workbooks(Filename).Sheets(startws).Range(address1).Offset(10, 13).HasFormula = True Then
With Workbooks(wbm).Sheets("Report") 'report
.Range("A" & reportrow).Value = runnumber
.Range("B" & reportrow).Value = Filename
.Range("C" & reportrow).Value = Workbooks(Filename).Sheets(startws).Name
.Hyperlinks.Add anchor:=.Range("D" & reportrow), Address:=FilePath & Filename, SubAddress:=Workbooks(Filename).Sheets(startws).Name & "!A1"
.Range("E" & reportrow).Value = "Error"
.Range("F" & reportrow).Value = "rolling probably done already in this sheet"
reportrow = reportrow + 1
End With
Else
With Workbooks(Filename).Sheets(startws)
.Range(Range(address1).Offset(0, 12).Address & ":" & Range(address2).Offset(0, 14).Address).Copy _
Range(Range(address1).Address & ":" & Range(address2).Offset(0, 2).Address)
Application.CutCopyMode = False
.Range(Range(address1).Offset(0, 16).Address & ":" & Range(address2).Offset(0, 16).Address).Copy _
Range(Range(address1).Offset(0, 3).Address & ":" & Range(address2).Offset(0, 23).Address)
Application.CutCopyMode = False
With Workbooks(wbm).Sheets("Report") 'report
.Range("A" & reportrow).Value = runnumber
.Range("B" & reportrow).Value = Filename
.Range("C" & reportrow).Value = Workbooks(Filename).Sheets(startws).Name
.Hyperlinks.Add anchor:=.Range("D" & reportrow), Address:=FilePath & Filename, SubAddress:=Workbooks(Filename).Sheets(startws).Name & "!A1"
.Range("E" & reportrow).Value = "Completed"
.Range("F" & reportrow).Value = "region1 rolled forward"
reportrow = reportrow + 1
End With
.Range(Range(address3).Offset(0, 12).Address & ":" & Range(address4).Offset(-1, 23).Address).Copy _
Range(Range(address3).Address & ":" & Range(address4).Offset(-1, 11).Address)
'///// here the error 1004 occurs
.Range(Range(address3).Offset(0, 12).Address & ":" & Range(address4).Offset(-1, 23).address).clearcontent
End With
End If
End If
The workbook and sheet need to be set with the variable.
Then when using it since it is a range itself just refer to it.
Sub clear2()
Dim region As range
Set region = Workbooks("xyz").Worksheets("abc")range("S509:AD618")
region.ClearContents
end sub
As to your next code; that is a different problem. The ranges inside the () need to allocated to the correct sheet parentage or it will use the active sheet.
The easiest is with a With block:
With sheets(sheetname)
.Range(.Range(address3).Offset(0, 12), .Range(address4).Offset(-1, 23)).ClearContents
End With
I had this same issue, but it turned out to be very simple. I had a row of cells merged together between columns E and F, so when I used this command I had to set the ClearContents from the top corner of my E column to the bottom row of my F column.
What did not work:
Range("E1:E10").Clear Contents
What did work:
Range("E1:F10").ClearContents
I can't believe such a simple thing left me so thwarted.
Can someone please help me?
Basically, I have three textboxes in my Excel spreadsheet, and I have a button that I want to save the details into a table on another sheet.
Each row as an 'x' in it, so that the program can know where to save the next data.
When I click the save button, an error comes up saying 'Object required.'
I'm god awful at VBA, seriously I have no clue, so maybe try to keep the answer in stupid-man terms so I don't mess up? I'm probably doing something minor wrong but I'm not sure. Here's my code:
Public Function findrow(texttofind As String) As Integer
Dim i As Integer
Dim firstTime As Integer
Dim bNotFound As Boolean
i = 5
bNotFound = True
Do While bNotFound
If Cells(i, 1).Value = texttofind Then
firstTime = i
bNotFound = False
End If
i = i + 1
Loop
findrow = firstTime
End Function
Sub SaveCustomer()
Dim rowno As Integer
Worksheets("Customers").Select
rowno = findrow("x")
Range("C" & rowno).Value = Invoice.TextBox21.Text
Range("D" & rowno).Value = Invoice.TextBox22.Text
Range("E" & rowno).Value = Invoice.TextBox23.Text
Worksheets("Invoice").Select
End Sub
I'm really bad at VBA, and my teacher isn't great, I just need to fix this one thing so I can pass my assignment. I just want to save the information from 3 textboxes into a table in another sheet. Thanks for any help received!
I'm sorry if this is a duplicate, but because I'm so bad at VBA, answers to other questions don't really help me at all.
Replace
Range("C" & rowno).Value = Invoice.TextBox21.Text
Range("D" & rowno).Value = Invoice.TextBox22.Text
Range("E" & rowno).Value = Invoice.TextBox23.Text
with
Range("C" & rowno).Value = Worksheets("Invoice").TextBox21.Text
Range("D" & rowno).Value = Worksheets("Invoice").TextBox22.Text
Range("E" & rowno).Value = Worksheets("Invoice").TextBox23.Text
I have SUMIF running really really slow. My data has 14,800 Rows and 39 Columns.
I do the following:
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
EDITED TO ADD more potentially relevant code that may be interacting with the SUMIF command
It may be relevant to the speed issue so I'll mention it. I get the user to open a file from wherever they may have stored the report. The file then stays open. Maybe that is a problem. I don't know if it should be some other way.. like I close it but keep the address in mind or something??
FilterType = "Text Files (*.txt),*.txt," & "Comma Separated Files (*.csv),*.csv," & "ASCII Files (*.asc),*.asc," & "All Files (*.*),*.*"
FilterIndex = 4
Title = "File to be Selected"
File_path = Application.GetOpenFilename(FileFilter:=FilterType, FilterIndex:=FilterIndex, Title:=Title)
If File_path = "" Then
MsgBox "No file was selected."
Exit Sub
End If
Set wbSource = Workbooks.Open(File_path)
Original_Name = ActiveWorkbook.Name
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Worksheets("Sheet1")
With ws1
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
For j = 1 To FinalColumn
If .Cells(1, j).Value = "Effec.Date" Then
Effective_Date_Column = j
ElseIf .Cells(1, j).Value = "FolderId" Then
FolderId_column = j
ElseIf .Cells(1, j).Value = "FolderNotional" Then
FolderNotional_column = j
End If
Next j
'range_Total_Folder_Fixed = .Cells(2, Total_Folder_Column).Address & ":" & .Cells(FinalRow, Total_Folder_Column).Address
range_FolderId_Fixed = .Cells(2, FolderId_column).Address & ":" & .Cells(FinalRow, FolderId_column).Address
range_FolderId_Cell = .Cells(2, FolderId_column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_FolderNotional_Fixed = .Cells(2, FolderNotional_column).Address & ":" & .Cells(FinalRow, FolderNotional_column).Address
Everything runs in 8-10 seconds until we come to the lie below. Now the total time jumps to a 150 seconds.
.Range(range_Total_Folder_Fixed).Formula = "=SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_FolderNotional_Fixed & ")"
Am I doing something wrong? Is there a better (more efficient) way to write a general formula?
EDIT: Code generated Raw Formula
Some of the excel worksheet functions in my code:
.Range(range_Isnumber).Formula = "=(RIGHT(" & range_TradeId_cell & ",2)<> ""IB"")*1"
.Range(range_Is_IB).Formula = "=(RIGHT(" & range_TradeId_cell & ",2)= ""IB"")*1"
.Range(range_Exceptions).Formula = "=(SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_Isnumber_fixed & ")= COUNTIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "))*1+(SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_Is_IB_fixed & ")= COUNTIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "))*1 "
.Range("C13").FormulaR1C1 = "=SUM(IF(FREQUENCY(MATCH([SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,[SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,0),MATCH([SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,[SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,0))>0,1))"
So Stuff like
Range("I2")=SUMIF($H$2:$H$5,H2,$G$2:$G$5)
Where the data could be like
RowG RowH RowI
Alice 1 4
Alice 3 4
Bob 9 17
Bob 8 17
Dan 2 2
EDIT2 : Implementing Sam's solution, I am getting errors:
Set range_FolderId_Fixed = .Range(.Cells(2, FolderId_column), .Cells(FinalRow, FolderId_column))
Set range_FolderId_Cell = .Range(.Cells(2, FolderId_column),.Cells(FinalRow, FolderId_column))
Set range_FolderNotional_Fixed = .Range(.Cells(2, FolderNotional_column), .Cells(FinalRow, FolderNotional_column))
Set range_Total_Folder_Fixed = .Range(.Cells(2, Total_Folder_Column), .Cells(FinalRow, Total_Folder_Column))
.Range(range_Total_Folder_Fixed).Value = SumIf_func(range_FolderId_Fixed, range_FolderId_Cell, range_FolderNotional_Fixed)
I am getting a type application defined or object defined error in the line below.
.Range(range_Total_Folder_Fixed).Value = SumIf_func(range_FolderId_Fixed, range_FolderId_Cell, range_FolderNotional_Fixed)
I have no idea what to do next.
Ok this is what I came up with
Public Function SumIf_func(rng As Range, _
criteria As Range, _
sumRange As Range) As Variant()
Dim rngArr() As Variant
Dim sumArr() As Variant
Dim criteriaArr() As Variant
Dim returnArr() As Variant
Dim temp As Double
rngArr = rng.Value2
sumArr = sumRange.Value2
criteriaArr = criteria.Value2
If UBound(sumArr) <> UBound(rngArr) Then _
Err.Raise 12345, "SumIf_func", "Sum range and check range should be the same size"
If UBound(sumArr, 2) <> 1 Or UBound(rngArr, 2) <> 1 Then _
Err.Raise 12346, "SumIf_func", "Sum range and check range should be a single column"
ReDim returnArr(1 To UBound(criteriaArr), 1 To 1)
For c = LBound(criteriaArr) To UBound(criteriaArr)
returnArr(c, 1) = Application.WorksheetFunction.SumIf(rng, criteriaArr(c, 1), sumRange)
Next c
SumIf_func = returnArr
End Function
This function takes in three ranges:
The range to check
The range where the criteria are
The range where the values to sum are
The range to check and the sum range should both be the same length and only be 1 column across.
The array that is returned will be the same size as the criteria array..
Here is an example of usage:
Public Sub test_SumIf()
Dim ws As Worksheet
Set ws = Sheet1
Dim rng As Range, sumRng As Range, criteria As Range
Set rng = ws.Range("A1:A100")
Set sumRng = ws.Range("B1:B100")
Set criteria = ws.Range("C1:C10")
ws.Range("D1:D10").Value = SumIf_func(rng, criteria, sumRng)
End Sub