Related
I Have Table like this, where i have to use macro because my table always change Every day (SSAS)
so i have use macro to filter automatically,
I am able to sum Amount based on same Vendorname, PONuber and Date on Column E (Subtotal).
and then filter to show Subtotal AMount >500
I want to show only row >500 (Column E), and pop up message to count PONumber (Column B) how many Unique PO Number (Only Visible Row to count)
i've been stuck how to count only Visible Unique PO Number and show it on Pop Up message
this is my Macro
Sub FilterCOunt_Click()
Dim Condition As Variant
Dim AVal As Variant
Dim LastRow As Long
Dim Hide, popup As Long
Dim message As String
Dim sht As Worksheet
'----------------------------
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
'---------------------------
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
Application.ScreenUpdating = False
Application.StatusBar = False
'------------------
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
Columns("E:Z").EntireColumn.Delete
Range("E:Z").EntireColumn.Insert
Range("E1").Value = "Sub Total >500 "
Set sht = ActiveSheet
LastRow = sht.Range("B" & Rows.Count).End(xlUp).Row
'-------------------
For i = 2 To LastRow ' with last row count =SUMIFS(I:I,A:A,A8,B:B,B8,C:C,C8)
AVal = "A" & i
BVal = "B" & i
CVal = "C" & i
Worksheets("Sheet3").Range("E" & i).Formula = "=SUMIFS(D:D,A:A," & AVal & ",B:B," & BVal & ",C:C," & CVal & ")"
Next i
With sht.Range("E1:E" & LastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:=">=500"
End With
'----------Count Pop UP
Dim CountPO As Long
Range("G1").FormulaArray = "=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"",MATCH(""&B2:B22,B2:B22&"",0))),ROW(B2:B22)- ROW(B2)+1),1))"
MsgBox "We Found " & CountPO & " PO Open(s)", _
vbInformation, "PO Found"
End Sub
and this is the formula to count it
{=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"",MATCH("~"&B2:B22,B2:B22&"",0))),ROW(B2:B22)-ROW(B2)+1),1))}
If you are pulling from a Database via SSAS you can use Power Query to link to your SSAS DataModel to Excel and you can insert a Calculated Measure in Dax from there with DistinctCount.
Count:=Calculate(DistinctCount(TableName[PONumber]),TableName[Amount]>500)
Alternatively if you want total insights on your specified issue you can add a measured column and then you can use Power Pivot to filter for your criteria live on refresh to the data model, completely negating the need for VBA entirely.
Incidentally it is pertinent to remember VBA is the sledge hammer of solutions please use the DataModel Tools before you ever think of a macro solution remember, VBA is an Application Programming Language and many IT Security Systems will disable it because it opens the system up for malware, you can literally change any file or program in VBA including calling delete system files
Meanwhile having a set DataModel in a locked file that requires user access behind LAN security is easily more secure than allowing your computer to have open programatic access.
This is an alternative formula (which doesn't require any filtering)
=SUM(--(FREQUENCY(IF(B2:B20>500,MATCH(A2:A20,A2:A20,0)),ROW(A2:A20)-ROW(A2)+1)>0))
It's an array formula so using VBA
Range("E1").FormulaArray = "=SUM(--(FREQUENCY(IF(B2:B20>500,MATCH(A2:A20,A2:A20,0)),ROW(A2:A20)-ROW(A2)+1)>0))"
A formula for your cell E2, which is not an array formula, is
=SUMPRODUCT((B2=B$2:B$23)*(A2=A$2:A$23)*(D$2:D$23))
Copy it down, as usual.
See here for why not using an array formula (if you have an alternative).
I am not certain this solves your question, as I did not fully understand it.
You can use the following code. I have implemented Collection to get the unique count.
This will count the unique rows in B column where value in E column > 500.
Private Sub GetUniqueCount() AS Variant
Dim Test As New Collection
Dim rng As Range
For i = 2 To 6 'Replace 6 with last row(without filtration)
Value = Cells(i, "B").Value
check = Contains(Test, Value)
If Cells(i, "E").Value > 500 And Not check And Len(Value) > 0 Then
Test.Add Value, CStr(Value)
End If
Next i
GetUniqueCount = Test.count
End Sub
'Function to check if the value exists in Collection or not
Public Function Contains(col As Collection, key As Variant) As Boolean
Dim obj As Variant
On Error GoTo err
Contains = True
obj = col(key)
Exit Function
err:
Contains = False
End Function
Step 1: Post my code to a new module.
Step 2: Bind you button to the macro named "filterAndCount"
Step 3: Click the buton and rejoice :-)
Code description:
1) The code loops all the rows in the table.
2) First it checks if the Sub Total is above the limit (500).
3) If equal or below it hides the row and moves on to the next row.
4) If above it checks if the value already exists in the array values above.
5) If it does not exists then the value is added to the array.
6) When all rows have been looped only rows with a Sub Total above the limit is visible.
7) Only the unique and visible PO Numbers have been added to the array.
8) The number of values in the array is dispayed in a message box.
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Double
Dim n As Double
Dim subTotalLimit As Double
Dim arr() As String
Sub filterAndCount()
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
i = 2
subTotalLimit = 500
n = 0
ReDim arr(0 To 0) As String
arr(0) = 0
ws.Columns("E:Z").EntireColumn.Delete
ws.Range("E:Z").EntireColumn.Insert
ws.Range("E1").Value = "Sub Total >500 "
Do While ws.Range("B" & i) <> ""
ws.Range("E" & i).Formula = "=SUMIFS(D:D,A:A,A" & i & ",B:B,B" & i & ",C:C,C" & i & ")"
If ws.Range("E" & i) < subTotalLimit Then
ws.Range("B" & i).EntireRow.Hidden = True
Else
If Not IsNumeric(Application.Match(Range("B" & i).Text, arr(), 0)) Then
arr(n) = Range("B" & i).Value
n = UBound(arr) + 1
ReDim Preserve arr(0 To n) As String
arr(n) = 0
End If
End If
i = i + 1
Loop
MsgBox UBound(arr)
End Sub
Use 2 Dictionary Objects, one for totals and one for unique PO's
Sub filterCOunt()
Const LIMIT = 500
Dim wb As Workbook, ws As Worksheet
Dim iRow As Long, iLastRow As Long, amount As Single
Dim sVendor As String, sPO As String, msg As String, sKey As String
Dim dictPO As Object, dictTotal As Object
Set dictPO = CreateObject("Scripting.Dictionary")
Set dictTotal = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
Set ws = ActiveSheet
iLastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
' first pass to total by po and vendor
For iRow = 2 To iLastRow
sVendor = Trim(ws.Cells(iRow, 1))
sPO = Trim(ws.Cells(iRow, 2))
amount = CSng(ws.Cells(iRow, 4))
sKey = sVendor & "_" & sPO
' sub total
If dictTotal.exists(sKey) Then
dictTotal(sKey) = dictTotal(sKey) + amount
Else
dictTotal.Add sKey, amount
End If
Next
' second pass for PO numbers
For iRow = 2 To iLastRow
sVendor = Trim(ws.Cells(iRow, 1))
sPO = Trim(ws.Cells(iRow, 2))
sKey = sVendor & "_" & sPO
' sub total
ws.Cells(iRow, 5) = dictTotal(sKey)
If dictTotal(sKey) > LIMIT Then
If Not dictPO.exists(sPO) Then
dictPO.Add sPO, iRow
End If
End If
Next
' filter
With ws.Range("E1:E" & iLastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:=">=" & LIMIT
End With
msg = "No of open PO's = " & dictPO.Count
MsgBox msg, vbInformation
End Sub
First, for your code Count Pop UP to work, let's change all from "" to """"
Second, to be able to notify a Unique PO Number and show it on Pop Up message, you must call the value received from cell G1, or, safer, use evaluate to get the result of this expression.
Your code will probably work now
'Dim CountPO As Long
Range("G1").FormulaArray = "=SUM(IF(FREQUENCY(IF(SUBTOTAL(3,OFFSET(B2,ROW(B2:B22)-ROW(B2),1)),IF(B2:B22<>"""",MATCH(""""&B2:B22,B2:B22&"""",0))),ROW(B2:B22)- ROW(B2)+1),1))"
MsgBox "We Found " & [g1].Value2 & " PO Open(s)", vbInformation, "PO Found"
however, your formula only counts all unique values including less than 500, in addition it is quite long. You can replace it using the shorter formula like the following code:
Dim formula_string As String
formula_string = "=SUMPRODUCT((B2:B22>3)*(C2:C22<>"""")/COUNTIF(B2:B22,B2:B22&""""))"
MsgBox "We Found " & Application.Evaluate(formula_string) & " PO Open(s)", vbInformation, "PO Found"
Hope it helps!
I have an invoice from a service provider that I need to format so I can use the data in Excel. But, the formatting is not consistent.
There are three (3) columns:
ID
Description
Amount
Many ID#s on the invoice have a one line (row) description.
But just as many have 2-11 lines (rows) of description.
The ID# is only listed once with each set of description lines.
Up to this point, I have used Excel Formulas. But, all my formulas is making things go very slow.
VBA would be way faster.
What I have done is created an index system looking for new ID#s.
Then I have created a cascading concatenate formula based on the given index system.
The amount has been easy to pull out using a LEFT formula, since the amount lists USD.
I then have a second sheet that does a VLOOKUP off of the first sheet to pull the ID's, final concatenated descriptions, and Amounts.
Our last invoice had 17,427 lines of data with only 1,717 ID#s.
Here is an example of what I am working with:
I want it to look like this:
one of the possible solutions below:
'assume that Id in column `A`, Description in column `B`, Amount in `C` and header in row 1
Sub somecode()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim sh As Worksheet: Set sh = wb.ActiveSheet
Dim lastRow&: lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
Dim idColumn As Range: Set idColumn = sh.Range("A1:A" & lastRow)
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim cl As Range, keyID, valueDescription$, valueAmount$
For Each cl In idColumn
If cl.Value <> "" And Not dic.exists(cl.Value) Then
dic.Add cl.Value, sh.Cells(cl.Row, "B").Value & "|" & sh.Cells(cl.Row, "C").Value
keyID = cl.Value
valueDescription = sh.Cells(cl.Row, "B").Value
valueAmount = sh.Cells(cl.Row, "C").Value
ElseIf cl.Value = "" Then
valueDescription = valueDescription & " " & sh.Cells(cl.Row, "B").Value
dic(keyID) = valueDescription & "|" & valueAmount
End If
Next cl
Set sh = wb.Sheets.Add: sh.Name = "Result " & Date & " " & Replace(Time(), ":", "-")
Dim dkey, xRow&: xRow = 1
For Each dkey In dic
sh.Cells(xRow, "A").Value = dkey
sh.Cells(xRow, "B").Value = Split(dic(dkey), "|")(0)
sh.Cells(xRow, "C").Value = Split(dic(dkey), "|")(1)
xRow = xRow + 1
Next dkey
sh.Columns("A:C").AutoFit
End Sub
test:
I wrote code for you to do this job. Please install it in a standard code module. That is one that you have to insert. None of the existing is suitable.
Option Explicit
Enum Nws ' Worksheet setup (set values as required)
NwsFirstDataRow = 2
NwsNumColumns = 8 ' total number of columns in the sheet
NwsID = 1 ' Columns: 1 = column A
NwsDesc ' undefined = previous + 1
NwsAmt = 5 ' 5 = column E
End Enum
Sub MergeRows()
' Variatus #STO 24 Jan 2020
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Rng As Range
Dim RowArr As Variant
Dim Desc As String, Amt As Double
Dim Tmp As Variant
Dim R As Long
' define workbook and worksheet as required
Set Wb = ActiveWorkbook ' this need not be ThisWorkbook
Set Ws = Wb.Worksheets("Invoice") ' change as appropriate
Application.ScreenUpdating = False
With Ws
R = .Cells(.Rows.Count, NwsDesc).End(xlUp).Row
For R = R To NwsFirstDataRow Step -1
If (R Mod 25) = 3 Then 'NwsFirstDataRow Then
Application.StatusBar = "Another " & R & " rows to process."
End If
Tmp = Trim(.Cells(R, NwsID).Value)
If Len(Tmp) Then
Set Rng = Range(.Cells(R, 1), .Cells(R, NwsNumColumns))
RowArr = Rng.Value
RowArr(1, NwsAmt) = TextToAmount(RowArr(1, NwsAmt))
If Len(Desc) Then
' if you want a comma instead of a line break
' replace Chr(10) with "," in the next line:-
RowArr(1, NwsDesc) = RowArr(1, NwsDesc) & Chr(10) & Desc
RowArr(1, NwsAmt) = RowArr(1, NwsAmt) + Amt
Desc = ""
Amt = 0
End If
With Rng
.Value = RowArr
.Cells.VerticalAlignment = xlTop
.Cells(NwsAmt).NumberFormat = "$#,##0.00"
End With
.Rows(R).AutoFit
Else
Tmp = Trim(.Cells(R, NwsDesc).Value)
If Len(Desc) Then Desc = Chr(10) & Desc
Desc = Tmp & Desc
Tmp = TextToAmount(.Cells(R, NwsAmt).Value)
If Tmp Then Amt = Amt + Tmp
.Rows(R).EntireRow.Delete
End If
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
Private Function TextToAmount(ByVal Amt As Variant) As Double
Dim Tmp As Variant
Tmp = Trim(Amt)
If Len(Tmp) Then Tmp = Mid(Tmp, InStr(Tmp, "$") + 1)
TextToAmount = Val(Tmp)
End Function
Before you can run it you need to set the enumerations at the top to tell the code where your data and columns are. Toward the same end, please set the variables for workbook (Wb) and worksheet (Ws) in the procedure itself.
Note that the code adds the price, if any, in the rows that are deleted to the amount set against the remaining item.
Finally, you will see that I programmed the different rows to become lines in a single cell. That isn't what you asked for. If you want the items separate by commas look for the remark in the code where you can change this.
I have been using the following code to send out emails, but I get a "run time error 13" when there is only one value in column M.
It works fine if I have more than two values. Any help please?
Sub testDemo()
Dim outlookApp As Object
Dim objMail As Object
Dim Region
Dim rng As Range
Dim Mailaddr As String
Dim MyRange As String
Dim arr As Variant
Dim lastrow As Long
Dim lastrow2 As Long
' Create email
Set outlookApp = CreateObject("Outlook.Application")
' Update with your sheet reference
With Sheets("Escalate")
lastrow = Range("A65536").End(xlUp).Row
lastrow2 = Range("M65536").End(xlUp).Row
Set rng = .Range("A1:I" & lastrow)
End With
arr = Range("M2:M" & lastrow2).Value
For Each Region In arr
myrangename = Worksheets("email").Range("C2:D200")
Mailaddr = WorksheetFunction.VLookup(Region, myrangename, 2, False)
On Error Resume Next
With outlookApp.CreateItem(0)
' Add table to Email body
.SentOnBehalfOfName = "script Tracking"
.cc = "Pearson.S#cambridgeenglish.org; Tracking.S#cambridgeenglish.org"
.HTMLBody = "Dear Team," & "<br><br>" & _
"blahblah " & "<br><br>" & _
GenerateHTMLTable(rng, CStr(Region), True) & "<br><br>" & _
"Many thanks in advance " & "<br><br>" & _
"Kind regards "
.To = Mailaddr
.Subject = "Region " & Region & " Outstanding scripts - " & Range("L1")
.Display
End With
skip:
Next Region
End Sub
Public Function GenerateHTMLTable(srcData As Range, Region As String, Optional FirstRowAsHeaders As Boolean = True) As String
Dim InputData As Variant, HeaderData As Variant
Dim HTMLTable As String
Dim i As Long
' Declare constants of table element
Const HTMLTableHeader As String = "<table>"
Const HTMLTableFooter As String = "</table>"
' Update with your sheet reference
If FirstRowAsHeaders = True Then
HeaderData = Application.Transpose(Application.Transpose(srcData.Rows(1).Value2))
InputData = Range(srcData.Rows(2), srcData.Rows(srcData.Rows.Count)).Value2
' Add Headers to table
HTMLTable = "<tr><th>" & Join(HeaderData, "</th><th>") & "</th></tr>"
End If
' Loop through each row of data and add selected region to table output
For i = LBound(InputData, 1) To UBound(InputData, 1)
' Test Region against chosen option
If Region = InputData(i, 9) Then
' Add row to table for output in email
HTMLTable = HTMLTable & "<tr><td>" & Join(Application.Index(InputData, i, 0), "</td><td>") & "</td></tr>"
End If
Next i
GenerateHTMLTable = HTMLTableHeader & HTMLTable & HTMLTableFooter
End Function
This will explain it better
Sub Sample()
Dim arr
lastrow2 = 2
arr = Range("M2:M" & lastrow2).Value
lastrow2 = 3
arr = Range("M2:M" & lastrow2).Value
End Sub
When the lastrow2 = 2, arr holds only one cell value and hence it becomes a Variant/(String/Double...etc depending on the value in cell M2)
When the lastrow2 > 2, arr becomes a 2D array and hence it becomes a Variant/Variant(1 to 2, 1 to 1)
The above can be verified using a Watch on arr in VBA.
This is the reason why your code works when you have more than one cell.
Because it is not a collection or an array, it is a single value - you can test this by checking IsArray(arr) before you run the For Each
There are several ways to fix this, but the fastest would be to include the line If Not IsArray(Arr) Then Arr = Array(Arr) before your For Each, to turn it into a 1-element array.
Other points to consider:
What is the purpose of your On Error Resume Next?
What is the purpose of your skip: label?
Variable myrangename is not defined - consider adding Option Explicit to the top of your Module, so that "Debug > Compile VBA Project" will catch those errors for you
I am trying to create "my first" formula-function, but can't get it to work.
It returns an error.
First I tested the function as a standard module and rendered the output in the debug console to test the outcome. All worked well.
However I can't get the same module to work as a function
Below the function:
It is called in this way =TEST(val;rng) | resulting in #value!
Function TEST(val As String, rng As Range) As String
Dim a, b As String
Dim cel, itm, tst, s As Range
Dim row, l, i As Integer
'-----------------------------------------------------
a = ""
b = ""
val = "ROX.RFL.avi.Rmd.ice"
Set rng = Range(Sheets("DGR").Cells(3, 3), Cells(3, 34))
'-----------------------------------------------------
For Each cel In rng.Cells
If InStr(UCase(val), UCase(cel)) Then
a = a & UCase(cel) & ","
row = Sheets("DGR").Cells(Rows.Count, cel.Column).End(xlUp).row
If row <> 3 Then
For Each itm In Range(Sheets("DGR").Cells(4, cel.Column), Cells(row, cel.Column))
b = b & UCase(itm) & ","
Next itm
End If
End If
Next cel
'-----------------------------------------------------
For Each tst In Split(a, ",")
If InStr(b, tst) > 0 Then TEST = tst
Next tst
End Function
Below the tested function as a module: (this worked properly)
Sub MKDGR()
Dim val, a, b As String
Dim rng, cel, itm, tst, s As Range
Dim row, l, i As Integer
'-----------------------------------------------------
a = ""
b = ""
val = "ROX.RFL.avi.Rmd.ice"
Set rng = Range(Sheets("DGR").Cells(3, 3), Cells(3, 34))
'-----------------------------------------------------
For Each cel In rng.Cells
If InStr(UCase(val), UCase(cel)) Then
a = a & UCase(cel) & ","
row = Sheets("DGR").Cells(Rows.Count, cel.Column).End(xlUp).row
If row <> 3 Then
For Each itm In Range(Sheets("DGR").Cells(4, cel.Column), Cells(row, cel.Column))
b = b & UCase(itm) & ","
Next itm
End If
End If
Next cel
'-----------------------------------------------------
For Each tst In Split(a, ",")
If InStr(b, tst) > 0 Then Debug.Print tst
Next tst
End Sub
There are lot of things which will or can go wrong. Let's address them one by one
Val is a reservd word in VBA. Avoid using that. Use something which is not a reserved word. For example inptS
Unlike Vb.Net, in VBA when you declare variables you have to explicitly declare each of them. Otherwise they are declared as Variant
When you are dealing with rows in Excel, use Long instead of Integer else you may get an Overflow Error
Use Error handling. This way the code will not break down and gracefully complete the execution and also let you know the problem if any.
Use Line Numbers in your code so that you can use Erl to get the line causing the error. Get MZTools Ver 3. It is free.
Fully qualify your objects. For example, If you don't qualify your range objects then the range object will refer to the Activesheet and the Activesheet may not be the sheet you think it is.
Now let's incorporate all the above in your code.
Code
Option Explicit
Function TEST(inptS As String, rng As Range) As String
Dim a As String, b As String
Dim cel As Range, itm As Range
Dim tst As Variant
Dim row As Long, l As Long, i As Long
'~~> Use error handling
10 On Error GoTo Whoa
'~~> Fully qualify your range objects
20 With Sheets("DGR")
30 For Each cel In rng.Cells
40 If InStr(UCase(inptS), UCase(cel)) Then
50 a = a & UCase(cel) & ","
60 row = .Cells(.Rows.Count, cel.Column).End(xlUp).row
70 If row <> 3 Then
80 For Each itm In .Range(.Cells(4, cel.Column), .Cells(row, cel.Column))
90 b = b & UCase(itm) & ","
100 Next itm
110 End If
120 End If
130 Next cel
140 End With
150 For Each tst In Split(a, ",")
160 If InStr(b, tst) > 0 Then
170 If TEST = "" Then
180 TEST = tst
190 Else
200 TEST = TEST & vbNewLine & tst
210 End If
220 End If
230 Next tst
240 Exit Function
Whoa:
250 TEST = "Unable to calculate value (" & _
Err.Description & _
", Error in line " & Erl & ")"
End Function
My "Chart data range" is ='sheet1'!$A$1:$Z$10. I'd like to make a VBA macro (or if anybody knows a formula I can use, but I couldn't figure one out) to increase the ending column of the range for chart1 by 1 every time I run the macro. So essentially:
chart1.endCol = chart1.endCol + 1
What is the syntax for this using ActiveChart or is there a better way?
Offset function dynamic range makes it possible.
Sample data
Steps
Define a dynamic named range
=OFFSET(Sheet1!$A$2,,,1,COUNTA(Sheet1!$A$2:$Z$2)) and give it a
name mobileRange
Right Click on Chart
Click on Select Data
This screen will come
Click on Edit under Legend Entries.(mobiles is selected)
change the Series value to point to mobileRange named range.
Now if data for future months are added to mobile sales it will automatically reflect in chart.
Assuming that you want to expand the range (by adding one extra column) to add one more observation for each series in you diagram (and not to add a new series), you could use this code:
Sub ChangeChartRange()
Dim i As Integer, r As Integer, n As Integer, p1 As Integer, p2 As Integer, p3 As Integer
Dim rng As Range
Dim ax As Range
'Cycles through each series
For n = 1 To ActiveChart.SeriesCollection.Count Step 1
r = 0
'Finds the current range of the series and the axis
For i = 1 To Len(ActiveChart.SeriesCollection(n).Formula) Step 1
If Mid(ActiveChart.SeriesCollection(n).Formula, i, 1) = "," Then
r = r + 1
If r = 1 Then p1 = i + 1
If r = 2 Then p2 = i
If r = 3 Then p3 = i
End If
Next i
'Defines new range
Set rng = Range(Mid(ActiveChart.SeriesCollection(n).Formula, p2 + 1, p3 - p2 - 1))
Set rng = Range(rng, rng.Offset(0, 1))
'Sets new range for each series
ActiveChart.SeriesCollection(n).Values = rng
'Updates axis
Set ax = Range(Mid(ActiveChart.SeriesCollection(n).Formula, p1, p2 - p1))
Set ax = Range(ax, ax.Offset(0, 1))
ActiveChart.SeriesCollection(n).XValues = ax
Next n
End Sub
Assuming that you only run the macro with a Chart Selected, my idea is to alter the range in the formula for each Series. You can of cause change to apply to all Charts in a Worksheet.
UPDATE: Have changed code to accommodate multiple series with screenshots
Formatting of new series string needs to include apostrophes around the worksheet name (already changed below): aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address. Also, if looking to change rows rather than columns, change the offset to Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(1, 0)) or as needed. Can also include oRng.Offset(1, 0) for the first element in the range to adjust the start position of the series: Set oRng = oRng.Worksheet.Range(oRng.Offset(1, 0), oRng.Offset(1, 0))
Sub ChartRangeAdd()
On Error Resume Next
Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
Dim i As Long, s As Long
Dim oRng As Range, sTmp As String, sBase As String
Set oCht = ActiveSheet.ChartObjects(1).Chart
oCht.Select
For s = 1 To oCht.SeriesCollection.count
sTmp = oCht.SeriesCollection(s).Formula
sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
aFormulaNew = Array()
ReDim aFormulaNew(UBound(aFormulaOld))
' Process all series in the formula
For i = 0 To UBound(aFormulaOld)
Set oRng = Range(aFormulaOld(i))
' Attempt to put the value into Range, keep the same if it's not valid Range
If Err.Number = 0 Then
Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address
Else
aFormulaNew(i) = aFormulaOld(i)
Err.Clear
End If
Next i
sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
oCht.SeriesCollection(s).Formula = sTmp
sTmp = ""
Next s
Set oCht = Nothing
End Sub
Sample data - Initial
After first run:
Second Run:
Third Run:
PatricK's answer works great with some minor adjustments:
Formatting of new series string needs to include apostrophes around the worksheet name on line 22 aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address. Also, if looking to change rows rather than columns, change the offset on line 21 to Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(1, 0)) or as needed. Can also include oRng.Offset(1, 0) for the first element in the range to adjust the start position of the series: Set oRng = oRng.Worksheet.Range(oRng.Offset(1, 0), oRng.Offset(1, 0))
Sub ChartRangeAdd()
On Error Resume Next
Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
Dim i As Long, s As Long
Dim oRng As Range, sTmp As String, sBase As String
Set oCht = ActiveSheet.ChartObjects(1).Chart
oCht.Select
For s = 1 To oCht.SeriesCollection.count
sTmp = oCht.SeriesCollection(s).Formula
sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
aFormulaNew = Array()
ReDim aFormulaNew(UBound(aFormulaOld))
' Process all series in the formula
For i = 0 To UBound(aFormulaOld)
Set oRng = Range(aFormulaOld(i))
' Attempt to put the value into Range, keep the same if it's not valid Range
If Err.Number = 0 Then
Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address
Else
aFormulaNew(i) = aFormulaOld(i)
Err.Clear
End If
Next i
sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
oCht.SeriesCollection(s).Formula = sTmp
sTmp = ""
Next s
Set oCht = Nothing
End Sub
PatricK and sirbedevire got me started with this fairly well. Now, I'm trying to consolidate it into a separate sub I can reference to process multiple charts. Unfortunately, I'm missing something in the referencing so it's not making the updates (and not producing an error).
1st sub using 2nd sub
If ws < numTabs - 1 Then
chartUpdate Summary, Chart_BidsByMonth ' Name of sheet with target chart, Name of target chart
chartUpdate Summary, Chart_SoldByMonth ' Name of sheet with target chart, Name of target chart
End If
2nd sub processing chart range update
Sub chartUpdate(shtRef As Variant, chtRef As Variant)
On Error Resume Next
Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
Dim n As Long, s As Long
Dim oRng As Range, sTmp As String, sBase As String
' Update chart referenced as chtRef '
Set oCht = Sheets(""" & shtRef & """).ChartObjects(""" & chtRef """).Chart
oCht.Select
For s = 1 To oCht.SeriesCollection.Count
sTmp = oCht.SeriesCollection(s).Formula
sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
aFormulaNew = Array()
ReDim aFormulaNew(UBound(aFormulaOld))
' Process all series in the formula
For n = 0 To UBound(aFormulaOld)
Set oRng = Range(aFormulaOld(n))
' Attempt to put the value into Range, keep the same if it's not valid Range
If Err.Number = 0 Then
Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
aFormulaNew(n) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address
Else
aFormulaNew(n) = aFormulaOld(i)
Err.Clear
End If
Next n
sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
oCht.SeriesCollection(s).Formula = sTmp
sTmp = ""
Next s
Set oCht = Nothing
' End charts update '
End Sub