Hello I have written a code for generating the graph and it is working correctly.
The problem is it is taking lot of time to generate. and i am not getting why it is taking time.
the code is
Dim cc As Chart
Set cc = ActiveWorkbook.Charts.Add
Set cc = cc.Location(Where:=xlLocationAsObject, name:=assume)
With cc
.ChartType = xlXYScatterLines
With .Parent
.Top = Columns(b).Offset(0, 4).Top
.Left = Columns(b).Offset(0, 4).Left
.name = "cc"
End With
End With
Dim sc As Series
Set sc = cc.SeriesCollection(1)
With sc
.Values = Columns(b).Offset(0, -3)
.XValues = Columns(b).Offset(0, -5)
End With
Please somebody help me
Try this, to just chart the rows of the column with actual data.
Sub makeChart(b As String, assume As String) 'i presupposed these arguments based on your code
Application.ScreenUpdating = False
Dim cc As Chart
Set cc = ActiveWorkbook.Charts.Add
Set cc = cc.Location(Where:=xlLocationAsObject, Name:=assume)
With cc
.ChartType = xlXYScatterLines
With .Parent
.Top = Columns(b).Offset(0, 4).Top
.Left = Columns(b).Offset(0, 4).Left
.Name = "cc"
End With
End With
Dim strValue As String, strXValue As String
'here you are using the passed column letter to find the specific column you want to chart
strValue = Split(Range(b & "1").Offset(, -3).Address, "$")(1) 'will return "C" if given column F
strXValue = Split(Range(b & "1").Offset(, -5).Address, "$")(1) 'will return "A" if given column F
Dim sc As Series
Set sc = cc.SeriesCollection(1)
With sc
'will select from row 1 to the last true used row in the given column
.Values = Range(strValue & "1:" & strValue & Range(strValue & Rows.Count).End(xlUp).Row)
.XValues = Range(strXValue & "1:" & strXValue & Range(strXValue & Rows.Count).End(xlUp).Row)
End With
Application.ScreenUpdating = True
End Sub
Have you turned off screen updating? Add this to the beginning of your code:
Application.ScreenUpdating = False
Then add this at the very end of your code:
Application.ScreenUpdating = True
Related
I want to check if a cell in a sheet s4 has the same value for each cell in the sheet s1
So i tried to "stop" the Next c setting the c value as the previous cell, until the condition be true.
i put msgbox c.Value & "hiiiii" to check the c position, and is always the next cell.
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim s3 As Worksheet
Dim s4 As Worksheet
Set s1 = ThisWorkbook.Sheets("test1")
Set s2 = ThisWorkbook.Sheets("test2")
Set s3 = ThisWorkbook.Sheets("test3")
Set s4 = ThisWorkbook.Sheets("test4")
Dim l As Integer
l = 8
lastrow = s4.Range("J" & s4.Rows.count).End(xlUp).row
Set rd = s4.Range("J2:J" & lastrow)
Set rf = s1.Range("A" & l)
For Each c In rd
msgbox c.Value & "hiiiii"
If rf.Value = "" Then: Exit For
If c.Value = rf.Value Then
s1.Range("B" & l).Value = c.Offset(, -1)
l = 8
Set rf = s1.Range("A" & l)
Else
l = l + 1
Set rf = s1.Range("A" & l)
Set c = c.Offset(-1, 0)
End If
Next c
There's a way to make it works?
Thank you
EDIT 1:
After some hours of breaking my head i changed the code and now it is working:
Dim l As Integer
Dim i As Integer
lastrow = s4.Range("J" & s4.Rows.count).End(xlUp).row
LastRow2 = s1.Range("A" & s1.Rows.count).End(xlUp).row
l = 8
i = 8
Set rd = s4.Range("J2:J" & lastrow)
Set rf = s1.Range("A" & i)
For Each c In rd
If c.Value <> rf.Value Then
For i = 8 To LastRow2
Set rf = s1.Range("A" & i)
If rf.Value = c.Value Then
rf.Offset(, 1).Value = c.Offset(, -1)
End If
Next i
Else
rf.Offset(, 1).Value = c.Offset(, -1)
End If
Next c
End Sub
A special thanks for Cyril and his tip about the another for options.
Screenshots/here refer:
CONSTRUCT
Fixed: comprises list of cells - press CMD button 'RUN' to select which values you want to compare against every populated cell of every other sheet.
This runs the macro Soln() (below).
test1-test3: arbitrary sheets comprising a medley of matching and mis-matched cell values/text etc. (contiguous / isolated cells etc.). Most content in test 1.
Audit_Trail: This will be removed/deleted if it exists when you run the macro so that a fresh sheet can be produced. This will display, for each target cell (selected step 1) and sheet (see 2) every cell (sheet/link/content) that did not match the respective target values.
CODE
(essential modules: Soln(), select cells - all the rest is 'bonus' - hope this works/helps you - assuming I understood issue correclty☺.)
Global addr(), target_cells(), s As String
Sub s_(new_txt)
Application.StatusBar = False
s = s & " --> " & new_txt
Application.StatusBar = s
End Sub
Sub Soln()
Application.StatusBar = False
s_ ("sub soln")
'Application.StatusBar = "Sub Soln()"
ReDim Preserve addr(0), target_cells(0)
Sheets("fixed").Move Before:=Sheets(1)
Call select_cells
Application.ScreenUpdating = False
m = -1
N_ = -1
K_ = -1
'Sheets(1).Activate
If sheet_exists("Audit_Trail") Then
Application.DisplayAlerts = False
Sheets("Audit_Trail").Delete
ThisWorkbook.Sheets.Add( _
After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "Audit_Trail"
Application.DisplayAlerts = True
End If
With Sheets("Audit_Trail")
.Range("a1").Value = "Target_value"
.Range("b1").Value = "Sheet"
.Range("c1").Value = "Link/Content"
End With
For Each sh In ActiveWorkbook.Sheets
For Each yy In target_cells
sh.Activate
If (sh.Name = "fixed") Or (sh.Name = "Audit_Trail") Then
Exit For
'ActiveSheet.Next.Select
Else
On Error Resume Next
Selection.SpecialCells(xlCellTypeConstants, 23).Select
For Each c In Selection
If c.Value = yy Then
Resume Next
Else
addr_temp = Evaluate("ADDRESS(" & c.Row & "," & c.Column & ",1,1,""" & c.Worksheet.Name & """)")
With Sheets("Audit_Trail")
m = m + 1
.Range("a2").Offset(m).Value = yy
.Range("b2").Offset(m).Value = sh.Name
.Range("c2").Offset(m).Value = "=" & addr_temp
End With
End If
Next
End If
Next
Next
Application.ScreenUpdating = True
Application.StatusBar = False
Call pivot_summary
End Sub
Sub select_cells() '#Tim Williams (2011) - https://stackoverflow.com/questions/7353711/let-the-user-click-on-the-cells-as-their-input-for-an-excel-inputbox-using-vba
s_ ("sub select_cells()")
Dim rRange As Range
N_ = -1
On Error Resume Next
Application.DisplayAlerts = False
Sheets("fixed").Activate
Default_ = Sheets("fixed").Range("J2:J4").Address
Set rRange = Application.InputBox(Prompt:= _
"Please select range with cells you would like to compare against every other cell in this workbook.", Title:="SPECIFY RANGE", Default:=Default_, Type:=8)
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
Else
For Each c In rRange
N_ = N_ + 1
ReDim Preserve target_cells(0 To N_)
target_cells(N_) = c.Value
Next
End If
Return
End Sub
Function sheet_exists(sh As String) As Boolean
s_ ("sheet_exists()")
'Dim w As Excel.Worksheet
On Error GoTo eHandle
Set w = ThisWorkbook.Worksheets(sh)
sheet_exists = True
Exit Function
eHandle:
sheet_exists = False
End Function
'******not really required - could ignore *********'
Sub pivot_summary()
Range("a1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
Selection, Version:=8).CreatePivotTable TableDestination:= _
ActiveSheet.Range("g2"), TableName:="PivotTable5", _
DefaultVersion:=8
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Target_value")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Sheet")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable5").AddDataField ActiveSheet.PivotTables( _
"PivotTable5").PivotFields("Link/Content"), "Sum of Link/Content", xlSum
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Sum of Link/Content")
.Caption = "Count of Link/Content"
.Function = xlCount
End With
ActiveSheet.PivotTables("PivotTable5").CompactLayoutRowHeader = "Target"
Range("H2").Select
ActiveSheet.PivotTables("PivotTable5").DataPivotField.PivotItems( _
"Count of Link/Content").Caption = "# mismatch"
Columns("G:H").Select
Selection.ColumnWidth = 11.27
Selection.Font.Name = "Brush Script MT"
Range("G22").Select
ActiveCell.FormulaR1C1 = "That's all folks! ?"
Range("G23").Select
ActiveWorkbook.Save
End Sub
GIF DEMO
OTHER INFO
To replicate for a single value, simply uapte the list in 1 (fixed) accordingly
This also creates a pivot in the Audit_Trail sheet summarises the extent of mismatches per sheet for each desired 'target value'.
I try to create dynamic chart with VBA , for example I have 5 students I need to create 5 chart
for each students .
Sub Macro4()
Rows("2:2").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range("Sheet1!$2:$2")
Rows("3:3").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range("Sheet1!$3:$3")
Rows("4:4").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range("Sheet1!$4:$4")
Range("D12").Select
ActiveWorkbook.Save
End Sub
I create this using Macro only for test but I try do that as dynamically because if I have more then 100 students it will be difficult , etc..
I hope you guys help me
Thanks
Try the next way, please. No need of any selection. Selection is useless, it only consumes Excel resources:
Sub AddCharts()
Dim sh As Worksheet, ch As Shape, chartNo As Long
Dim prevWith As Long, i As Long
Set sh = ActiveSheet 'the sheet where the charts to be created
'chartNo = 5
chartNo = = Worksheets("Sheet1").Range("A" & rows.count).End(xlUp).row - 1
For i = 1 To chartNo
Set ch = sh.Shapes.AddChart
ch.Chart.ChartType = xlColumnClustered
ch.Chart.SetSourceData Source:=Range("Sheet1!$" & i + 1 & ":$" & i + 1)
ch.Chart.Parent.left = sh.Range("A1").left + prevWith 'here the first left chart position to be set
prevWith = ch.Chart.Parent.width 'the chart width, the next one will be added to its right side
Next i
ActiveWorkbook.Save
End Sub
Change your macro like this:
Sub Macro4(startRow As String, stud As Long)
For k = 1 To stud
Dim constr() As String
Dim cn As String
cn = ""
constr = Split(strtRow,":")
For Each c in constr
cn = cn & "$" & c & ":"
Next
cn = Left(cn, Len(cn) - 1)
Rows(strtRow).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range("Sheet1!" & cn)
Dim str As String
str = ""
For each d in constr
str = str & (CInt(d)+1) & ":"
Next
str = Left(str, Len(str) - 1)
strtRow = str
Next
Now call like
Macro4("2:2",3)
Will do on 2:2 to 4:4
I have a VBA script that I use to generate multiple line charts in Excel. It used to include 2 series collections per chart (reading from 2 columns) but I since modified it for only one. However now I want it to do 2 series' again but want it to read both collections from the same column. Is this possible?
I've tried modifying the .SeriesCollection(2) to go to the next range further down the column. However this just returns an error 4001.
Sub CreateCharts()
Dim ws As Worksheet
Dim ch As Chart
Dim NumCharts As Integer, ChartName As String, ChartTitle As String, i As Integer
Set ws = Sheets("Charts")
NumCharts = WorksheetFunction.CountA(ws.Rows(2))
For i = 2 To NumCharts Step 1 '1 column of data per chart
ChartName = ws.Cells(2, i) '"chrt" & Range(Col1 & 2)
ChartTitle = ws.Cells(2, i) 'Range(Col1 & 2)
Set ch = Charts.Add
With ch
.ChartType = xlLine
.SetSourceData Source:=ws.Range(ws.Cells(3, i), ws.Cells(20, i)), _
PlotBy:=xlColumns 'range of data for each chart
.SeriesCollection(1).XValues = ws.Range("A3:A20") 'data range of line 1 (test data)
.SeriesCollection(2).XValues = ws.Range("A21:A38") 'data range of line 2 (Rw curve)
.Name = ChartName
.HasTitle = True
.ChartTitle.Characters.text = "#" & ws.Cells(2, i) '& " " & ws.Cells(1, i) 'remove title 'change to "ws.Cells(2, i)" to see titles
.ChartTitle.Left = 600
'HORiZONTAL X AXiS
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.text = "Frequency (Hz)"
.Axes(xlCategory).MajorTickMark = xlNone
.Axes(xlCategory).AxisBetweenCategories = False
.Axes(xlCategory).Border.LineStyle = None
'VERTiCAL Y AXiS
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.text = "Sound Reduction Index (dB)"
.Axes(xlValue).TickLabels.NumberFormat = "0"
.Axes(xlValue).MajorTickMark = xlNone
.Axes(xlValue).HasMajorGridlines = False
.Axes(xlValue).MinimumScale = 10 'minimum value on y
.Axes(xlValue).MaximumScale = 80 'maximum value on y
.Axes(xlValue).Border.LineStyle = None
'LEGEND
.HasLegend = False
'FONT SPECiFiCATiONS
.ChartArea.Format.TextFrame2.TextRange.Font.Size = 14
.ChartArea.Format.TextFrame2.TextRange.Font.Name = "Myriad Pro"
.ChartArea.Border.LineStyle = xlNone
'CHART POSiTiON, SiZE & COLOUR
.PlotArea.Format.Fill.ForeColor.RGB = RGB(242, 242, 242) 'grey background
.PlotArea.Top = 0
.PlotArea.Left = 20
.PlotArea.Height = 440
.PlotArea.Width = 420
'CHART LiNE COLOURS
.SeriesCollection(1).Border.Color = RGB(27, 117, 188) 'first line colour
'.SeriesCollection(2).Border.Color = RGB(0, 0, 0) 'second line colour
'.SeriesCollection(2).LineStyle = xlDashDot
End With
Next i
End Sub
Here is an image example of what I'm wanting to achieve.
Code is slightly modified and tested to work as far my understanding of the objective (to create one 2 series charts per column. 1st series Row 3-20 and 2nd series 21 to 38). Only issue with code was absence of SeriesCollection(2). It is modified to add necessary SeriesCollection and to delete if any automatically added series collection exist.
For i = 2 To NumCharts Step 1 '1 column of data per chart
ChartName = ws.Cells(2, i) '"chrt" & Range(Col1 & 2)
ChartTitle = ws.Cells(2, i) 'Range(Col1 & 2)
Set ch = Charts.Add
'Delete if any automatically added series exist
For x = ch.SeriesCollection.Count To 1 Step -1
ch.SeriesCollection(x).Delete
Next
With ch
.ChartType = xlLine
.SeriesCollection.Add ws.Range(ws.Cells(3, i), ws.Cells(20, i))
.SeriesCollection.Add ws.Range(ws.Cells(21, i), ws.Cells(38, i))
.SeriesCollection(1).XValues = ws.Range(ws.Cells(3, 1), ws.Cells(20, 1))
.SeriesCollection(2).XValues = ws.Range(ws.Cells(21, 1), ws.Cells(38, 1))
.Name = ChartName
I have created a chart using vba excel, then accidentally populate a graph that show the user and the counts which I prefer. But stupid of me I forgot to save, due to testing. Now I cant get the logic how to set it again. please help, thanks
Sample Data
Operator Counts Team
OPSHAF 123 A
OPSAJC 1245 B
OPSZAL 23 A
OPSJGY 162 C
OPSOSM 54 D
Sub CreateChart()
Dim rEmailRng As Range
Dim oEmailCht As Object
Dim cEmailCht As Chart
Dim coEmailCht As ChartObject
Dim iEmailRow As Integer
Dim sEmailSeries As Series
Dim scEmailSerCol As SeriesCollection
On Error Resume Next
Set wb = ThisWorkbook
Set wbsh2 = wb.Worksheets("Email")
Set coEmailCht = wbsh2.ChartObjects.Add(Range("E5").Left, Range("E5").Top, 500, 300)
coEmailCht = "Email Requests Processed" '& year
Set cEmailCht = coEmailCht.Chart
With cEmailCht
.HasLegend = False
.HasTitle = True
.Axes(xlValue).MinimumScale = 50
.Axes(xlValue).MaximumScale = 1500
.ChartTitle.Text = "Email Processed by Operator"
Set scEmailSerCol = .SeriesCollection
Set sEmailSeries = scEmailSerCol.NewSeries
With sEmailSeries
.Name = Range("A1").Offset(0, 1).Value
.XValues = Range(Range("A1").Offset(1, 0), Range("A1").End(xlDown))
.Values = Range(Range("A1").Offset(1, 1), Range("A1").Offset(1, 1).End(xlDown))
.ChartType = xl3DColumnClustered
End With
End With
Welcome To SO. If Your Objective is that axis label contain Count along with Operator then simply try
With sEmailSeries
'
.XValues = Range("A2:B" & Range("B2").End(xlDown).Row)
if you want team name also then
.XValues = Range("A2:C" & Range("C2").End(xlDown).Row)
I'm trying to place two chart objects on a single sheet and encountering difficulties with Excel 2010.
My code was working fine with a single chart object but when I added an additional chart: the chart type, title and other attributes are not registering up on the second chart.
The two charts should have the same structure but reference a different column on the sheet. I've looked around but couldn’t find a solution. Please suggest how to fix this problem. I’m posting partial code only but can post the rest of the code if it's helpful. Sorry if the code is too long...
I really appreciate your help.
Function GraphMFI(Arr() As Variant, Arr2() As Variant, ChartName As String, ChartName2 As String)
Dim i As Long, l As Long
Dim rng As Range, aCell As Range
Dim MyArY() As Variant, MyArX() As Variant
Dim LastRow As Long, iVal As Long
Dim Count As Long, SumArr As Long, AvgC As Long
Application.EnableEvents = False
'***********************************************************************
'Code that calculates x and y values not shown
'**************************************************************************
On Error Resume Next
'~~~~~~~~~chart code begins
Call DeleteallCharts 'delete all existing charts from active sheet
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~add both charts~~~~~~
Set objChart = ActiveSheet.ChartObjects.Add _
(Left:=410, Width:=500, Top:=15, Height:=250)
objChart.Chart.ChartType = xlXYScatterLines
Set objChart2 = ActiveSheet.ChartObjects.Add _
(Left:=410, Width:=500, Top:=300, Height:=250)
objChart.Chart.ChartType = xlXYScatterLines
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~add both charts~~~~~~
Dim objChartSeriesColl As SeriesCollection
Dim objChartSeriesColl2 As SeriesCollection
Set objChartSeriesColl = objChart.Chart.SeriesCollection
Set objChartSeriesColl2 = objChart2.Chart.SeriesCollection
'delete all chart series
'~~~~~~~~~~~first chart
With objChartSeriesColl.NewSeries '~~~raw data
.Name = "Inner Run Variability"
.Values = Arr
.XValues = rng
.MarkerSize = 10
.
'code not shown
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~First Chart
With objChartSeriesColl.NewSeries '~~~average series one
Dim nPts As Long
.Name = "Mean"
.Values = AvgArr '~~~~average of Negative control
.XValues = rng '~~~dates
'.AxisGroup = xlSecondary
.ChartType = xlXYScatterLinesNoMarkers
'With mySrs
nPts = .Points.Count
.Points(nPts).ApplyDataLabels _
Type:=xlDataLabelsShowValue, _
AutoText:=True, LegendKey:=False
.Points(nPts).DataLabel.Text = .Name
.Points(nPts).ApplyDataLabels Type:=xlDataLabelsShowValue, _
AutoText:=True, LegendKey:=False
With .DataLabels
.AutoScaleFont = False
.Font.Size = 10
.Font.ColorIndex = 3
.Position = xlLabelPositionAbove
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
End With
'~~~~~~~~~~~~~~~~~~
End With
With objChartSeriesColl.NewSeries '~~plus two stdev series two
.Name = "plus 2 stdev"
.Values = TwoPlusSdtDevArr
.XValues = rng '~~~dates
End With
With objChartSeriesColl.NewSeries 'minus three stdev series three
.Name = "minus 2 stdev"
.Values = TwiceStdDevArr
.XValues = rng
.ChartType = xlXYScatterLinesNoMarkers
End With
'~~~~~~~~~~~Second chart
With objChartSeriesColl2.NewSeries '~~~raw data
.Name = "Inner Run Variability"
.Values = Arr2
.XValues = rng
.MarkerSize = 10
End With
'~~~~~adding series to the second chart
With objChartSeriesColl2.NewSeries '~~~average
Dim nPts2 As Long
.Name = "Mean"
.Values = AvgArr
.XValues = rng '~~~dates
.ChartType = xlXYScatterLinesNoMarkers
End With
'....more series not shown here
With objChart
.Axes(xlCategory).TickLabels.NumberFormat = "m/d/yyyy" 'changes Xaxis text format
.Axes(xlValue).TickLabels.NumberFormat = "General" 'changes Yaxis Text Format
.SetElement (msoElementChartTitleAboveChart) 'adds chart title above chart
.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'adds Xaxis title
.SetElement (msoElementPrimaryValueAxisTitleRotated) 'adds rotated Yaxis Title
.ChartTitle.Text = ChartName 'adds chart title above chart
.SetElement (msoElementLegendNone)
'~~~~~~~~~~~~set plot area
With .PlotArea
.Width = .Width / 2
.Height = .Height / 2
.Left = 16
.Top = 16
.Width = 450
End With
'~~~~~~~~~~~~~~~~
With .Axes(xlCategory, xlPrimary)
.AxisTitle.Text = "Run Dates" 'renames Xaxis title to "X Title"
.AxisTitle.Font.Bold = True
End With
With .Axes(xlValue, xlPrimary)
.AxisTitle.Text = "Sample Dates" 'renames Xaxis title to "X Title"
.AxisTitle.Text = "MFI Values" 'renames Yaxis title to "Y Title"
End With
.Axes(xlCategory).MinimumScale = ChartMin '~~adds min
.Axes(xlCategory).MaximumScale = ChartMax '~~ adds max
.Parent.Placement = xlFreeFloating
With .ChartArea.Format.Line
.Visible = msoCTrue
.Style = msoLineSingle
.Weight = 1
.ForeColor.RGB = RGB(255, 255, 255)
End With
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'more code
End With
''''~~~~~~~~~~~~~Second Chart begins here
With objChart2
'..........
'code almost the same as 'with objChart'
Application.EnableEvents = True
End With
End Function