I have a sas code that writes text (Lets call is "sas text") in an excel file and then VBA creates the graph in excel and copy the "sas text" in the title.
Whenver the "sas text" length is samll the VBA works fine, but whenever the "SAS text" length is long, VBA gives a run time error - "VBA, method "text" of object error.
My code is:
Sub FormatChart()
Let Title = Sheets("Sheet1").Cells(2, 1)
Let Title1 = Sheets("Sheet1").Cells(2, 2)
Let Title2 = Sheets("Sheet1").Cells(2, 3)
Let Title3 = Sheets("Sheet1").Cells(2, 4)
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.SeriesCollection(1).Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Axes(xlCategory).Select
ActiveChart.Axes(xlCategory).ReversePlotOrder = True
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartTitle.Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartTitle.Text = Title & Title3 & Chr(10) & Title1 & "to " & Title2 & ": People with 25 or more visits" & Chr(10) & "Source: www.xxxxxxxxxxx.xxx.xxx"
With ActiveChart.ChartTitle.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 8
End With
With ActiveChart.Axes(xlCategory).TickLabels.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 7
End With
With ActiveChart.Axes(xlValue).TickLabels.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 7
End With
With ActiveChart.PlotArea.Interior
.ColorIndex = 2
.PatternColorIndex = 1
.Pattern = xlSolid
End With
Range("S4").Select
ActiveWindow.SmallScroll Down:=48
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Legend.Select
Selection.delete
ActiveWindow.SmallScroll Down:=45
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.PlotArea.Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveWindow.SmallScroll Down:=-45
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveWindow.SmallScroll Down:=-54
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Select
ActiveChart.ChartArea.Width = 500
ActiveChart.ChartArea.Height = 1000
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Axes(xlValue).Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Axes(xlValue).Select
ActiveChart.Axes(xlValue).MinimumScale = 0
ActiveChart.Axes(xlValue).MaximumScale = 100
ActiveChart.Axes(xlValue).MajorUnit = 20
ActiveChart.Axes(xlValue).MajorUnit = 10
With ActiveChart.SeriesCollection(1)
.Interior.Color = RGB(0, 51, 153)
End With
ActiveSheet.ChartObjects("Chart 1").Activate
Dim c As Chart
Dim s As Series
Dim iPoint As Long
Dim nPoint As Long
Set c = ActiveChart
Set s = c.SeriesCollection(1)
nPoint = s.Points.Count
For iPoint = 1 To nPoint
If s.XValues(iPoint) = "MINNESOTA STATE AVERAGE " Then
s.Points(iPoint).Interior.Color = RGB(80, 116, 77)
End If
If s.XValues(iPoint) = "NATIONAL AVERAGE " Then
s.Points(iPoint).Interior.Color = RGB(80, 116, 77)
End If
Next iPoint
ActiveSheet.ChartObjects("Chart 1").Activate
Selection.Cut
Sheets("Chart1").Select
ActiveChart.Paste
End Sub
On debugging, it highlights this line of the code
" ActiveChart.ChartTitle.Text = Title & Title3 & Chr(10) & Title1 & "to " & Title2 & ": People with 25 or more visits" & Chr(10) & "Source: www.xxxxxxxxxxx.xxx.xxx"
"
Thanks much!
The ChartTitle.Text is limited to 255 characters.
Confirmed via experimentation the following fails when x = 256.
Sub Macro2()
'
Dim x as long
With ActiveChart
.HasTitle = True
For x = 1 To 500
.ChartTitle.Text = Characters(x)
Next
End With
End Sub
Function Characters(x As long)
dim charCount as long
For charCount = 1 To x
Characters = Characters & "."
Next
End Function
My advice would be to truncate your title ChartTitle.Text = Left("your built string",255)
Several things in Excel are limited to 255 characters due to being (old style) Pascal counted strings with the length in the first byte.
To workaround this issue, you can superimpose a TextBox and populate that with your title. Note that there is still a 255 characters at a time limit when interacting, but you can build up.
The following will not work:
Sub WillNotWork()
Const LongString As String = _
"Pi = 3.1415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116094330572703657595919530921861173819326117931051185480744623799627495673518857527248912279381830119491298336733624406566430860213949463952247371907021798609437027705392171762931767523846748184676694051320005681271452635608277857713427577896091736371787214684409012249534301465495853710507922796892589235420199561121290219608640344181598136297747713099605187072113499999983729780499510597317328160963185950244594553469083026425223082533446850352619311881710100031378387528865875332083814206171776691473035982534904287554687311595628638823537875937519577818577805321712268066130019278766111959092164..."
Dim title As TextFrame
Set title = ActiveSheet.Shapes("Text Box 1").TextFrame
title.Characters.Text = LongString 'fails silently
End Sub
But this will:
Sub Works()
Const LongString As String = _
"Pi = 3.1415926535897932384626433832795028841971693993751058209749445923078164062862089986280348253421170679821480865132823066470938446095505822317253594081284811174502841027019385211055596446229489549303819644288109756659334461284756482337867831652712019091456485669234603486104543266482133936072602491412737245870066063155881748815209209628292540917153643678925903600113305305488204665213841469519415116094330572703657595919530921861173819326117931051185480744623799627495673518857527248912279381830119491298336733624406566430860213949463952247371907021798609437027705392171762931767523846748184676694051320005681271452635608277857713427577896091736371787214684409012249534301465495853710507922796892589235420199561121290219608640344181598136297747713099605187072113499999983729780499510597317328160963185950244594553469083026425223082533446850352619311881710100031378387528865875332083814206171776691473035982534904287554687311595628638823537875937519577818577805321712268066130019278766111959092164..."
Dim title As TextFrame
Set title = ActiveSheet.Shapes("Text Box 1").TextFrame
title.Characters.Text = ""
For i = 0 To Len(LongString) \ 255
title.Characters(i * 255 + 1).Insert Mid$(LongString, 255 * i + 1, 255)
Next
End Sub
Related
This is a little challenging to me
I have the following code which works just like I wanted. But I need the code to loop through Sheet1 Column A and copy and paste the value to Sheet2(R1) Then loop through Sheet1 column B and copy each value paste it to Sheet2(I7) then save the worksheet as a new PDF document
See Picture for example excel sheet
example
Sub Macro2()
'
' Macro2 Macro
'
'
Sheets("Sheet1").Select
Range("A2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("R1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Sheets("Sheet1").Select
Range("B2").Select
Selection.Copy
Sheets("Sheet2").Select
Range("I7").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
Dim i As Integer
For i = 1 To 2
Next i
ThisWorkbook.Sheets("Sheet2").Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & CStr(i) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
End With
End Sub
You can use the following codes to loop through rows and/or columns if you add the function below at the end (below your actual sub) of the same "Module" your sub is located in.
sub yourcode
ThisWorkbook.Worksheets("worksheetX").range(col_letter(column_number) & rownumber).Value
end sub
Function col_letter(lngCol As Long) As String 'Sub nr_to_letter()
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
col_letter = vArr(0)
End Function
And it will automatically convert the column_number to the column letter in the .range("..
And the following generalized code detects the last row of your column:
'Find the last used row in a Column: column B in this example
Dim LastRow As Long
sheets(name(Sheet)).Select
sheets(name(Sheet)).Activate
'MsgBox (Sheet)
With ActiveSheet
LastRow = .Cells(.Rows.count, "B").End(xlUp).Row
End With
I learned a lot of the basics by looking up standard solutions to basic problems I stumbled upon from:
Source: http://www.rondebruin.nl/
And I think this code could perform your desired task:
Sub Macro2()
'
' Macro2 Macro
'
'
Sheets("Sheet1").Select
Range("A2").Select
'detect last row in column A sheet1:
Dim LastRow As Long
Sheets("Sheet1").Select
Sheets("Sheet1").Activate
'MsgBox (Sheet)
With ActiveSheet
LastRow_A = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (LastRow_A)
'here the function to convert column number to column letter is used:
'Range(col_letter(1) & "2:A" & LastRow).Select
MsgBox ("As you can see the function converts the index of the col_letter to a alphabetic letter: " & col_letter(1))
For loop_through_column_A = 2 To LastRow_A
Range(col_letter(1) & loop_through_column_A).Select
Selection.Copy
Sheets("Sheet2").Select
Range("R" & loop_through_column_A - 1).Select 'ensure it starts pasting at row 1
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Next loop_through_column_A
Sheets("Sheet1").Select
Range("B2").Select
'detect last row in column B sheet1:
Dim LastRow_B As Long
Sheets("Sheet1").Select
Sheets("Sheet1").Activate
'MsgBox (Sheet)
With ActiveSheet
LastRow_B = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
MsgBox (LastRow_B)
'loop through column Sheet1
For loop_through_column_B = 2 To LastRow_B
Range("B" & loop_through_column_B).Select
Selection.Copy
Sheets("Sheet2").Select
Range("I" & 5 + loop_through_column_B).Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
'To save the pdf every iteration (after you have already completely iterated through column A in the first for-loop:
'"Insert here."
Next loop_through_column_B
'include this in the loop if you want to save the pdf every time you add a different pasted row where it says: "Insert here."
ThisWorkbook.Sheets("Sheet2").Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & CStr(i) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
End Sub
'Here the following function IS used:
Function col_letter(lngCol As Long) As String 'Sub nr_to_letter()
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
col_letter = vArr(0)
End Function
I keep getting Compile error invalid Next Control Variable Reference Anyone can help.
I need the code to loop through Sheet1 Column A and copy and paste the value to Sheet2(R1) Then loop through Sheet1 column B and copy each value paste it to Sheet2(I7) then save the worksheet as a new PDF document
Private Sub CommandButton1_Click()
Dim i As Long
Dim n As Long
Dim m As Integer
NumRows1 = Range("A2", Range("A2").End(xlDown)).Rows.Count
NumRows2 = Range("B2", Range("B2").End(xlDown)).Rows.Count
For i = 2 To NumRows1
Range("i").Select
Sheets("Sheet1").Select
Selection.Copy
Sheets("Sheet2").Select
Range("R1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
For n = 2 To NumRows2
Range("n").Select
Sheets("Sheet1").Select
Selection.Copy
Sheets("Sheet2").Select
Range("I7").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
For m = 0 To 300
Sheets("Sheet2").Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & CStr(m) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
Next i
Next n
Next m
Application.ScreenUpdating = True
End Sub
Try this
Sub Demo()
Dim srcSht As Worksheet, destSht As Worksheet
Dim lastRow As Long
Dim cel As Range, rng As Range
Set srcSht = ThisWorkbook.Sheets("Sheet1") 'this is your source sheet
Set destSht = ThisWorkbook.Sheets("Sheet2") 'this is your destination sheet
With srcSht
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'get last row with data in Column A of srcSht
For Each cel In .Range("A2:A" & lastRow) 'loop through each cell in Column A of srcSht
cel.Copy destSht.Range("R1") 'copy cell in Column A of srcSht to Cell R1 of destSht
cel.Offset(0, 1).Copy destSht.Range("I7") 'copy cell in Column B of srcSht to Cell I7 of destSht
Set rng = Union(destSht.Range("R1"), destSht.Range("I7")) 'union cell R1 and I7
With rng.Font 'format union range
.Name = "Calibri"
.Size = 20
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
destSht.Range("I7").Font.Size = 16
'I've not tested save as pdf file part
destSht.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & (cel.Row - 1) & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=True, _
OpenAfterPublish:=False
Next cel
End With
End Sub
Note : I've not tested saving file as pdf part.
I already created the dropdownbox and it points to a certain directory which contains the .csv files. I can see the files in the dropdownbox, but I want to open them as soon as I click on them. How can I accomplish this in the Visual Basic editor? Here is my code of the dropdownbox.
P.S. I just started programming in Visual Basic.
Option Explicit
Private Sub DropdownFiles()
Dim name
For Each name In ListDirectory(Path:="C:\Users\Test\Desktop\Macro's\", AttrInclude:=vbNormal, AttrExclude:=vbSystem Or vbHidden)
Me.ComboBox1.AddItem name
Next name
End Sub
Function ListDirectory(Path As String, AttrInclude As VbFileAttribute, Optional AttrExclude As VbFileAttribute = False) As Collection
Dim Filename As String
Dim Attribs As VbFileAttribute
Set ListDirectory = New Collection
Filename = Dir(Path, AttrInclude)
While Filename <> ""
Attribs = GetAttr(Path & Filename)
' If Attribs And AttrInclude And Not (Attribs And AttrExclude) Then
If Not (Attribs And AttrExclude) Then
ListDirectory.Add Filename, Path & Filename
End If
Filename = Dir
Wend
End Function
Private Sub OpenButton()
End Sub
The macro which I run. It's located in a directory near the .csv files
Private Sub Macro()
'
' Macro
'
'
Dim docpath As String
docpath = "TEXT;" & ThisWorkbook.Path & "\Test.csv"
'With ActiveSheet.QueryTables.Add(Connection:="TEXT;C:\Users\Test\Desktop\Macro's\Test.csv", Destination:=Range("$A$1"))
With ActiveSheet.QueryTables.Add(Connection:=docpath, Destination:=Range("$A$1"))
' docpath, Destination:=Range("$A$1"))
' .CommandType = 0
.name = "calllog"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(4, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
ActiveSheet.name = "Sheet1"
End With
Range("A1:I9999").Select
Selection.Columns.AutoFit
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("I2:I829").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("I2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("I2:I9999")
.Header = xlNo
.MatchCase = True
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("T1").Select
ActiveCell.FormulaR1C1 = "60"
Range("T1").Select
Selection.Copy
Range("F2:F829").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
Range("G2:G829").Select
Range("T1").Select
Selection.Copy
Range("G2:G829").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlDivide, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "0.00"
Range("T1").Select
Selection.ClearContents
Range("A437:I829").Select
Selection.Cut Destination:=Range("A439:I831")
Range("A439:I831").Select
Range("A439:I506").Select
Range("I506").Activate
Selection.Cut Destination:=Range("A438:I505")
Range("L452").Select
Range("A2:A436,F2:F436").Select
Range("F436").Activate
ActiveSheet.Shapes.AddChart2(216, xlBarClustered).Select
ActiveChart.SetSourceData Source:=Range( _
"Sheet1!$A$2:$A$436,Sheet1!$F$2:$F$436")
ActiveSheet.Shapes("Chart 1").IncrementLeft 304.5
ActiveSheet.Shapes("Chart 1").IncrementTop -139.5
ActiveChart.ChartTitle.Select
ActiveChart.ChartTitle.Text = "Aantal gebelde minuten (Inbound)"
Selection.Format.TextFrame2.TextRange.Characters.Text = _
"Aantal gebelde minuten (Inbound)"
With Selection.Format.TextFrame2.TextRange.Characters(1, 32).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 14).Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 14
.Italic = msoFalse
.Kerning = 12
.name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Spacing = 0
.Strike = msoNoStrike
End With
With Selection.Format.TextFrame2.TextRange.Characters(15, 18).Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 14
.Italic = msoFalse
.Kerning = 12
.name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Spacing = 0
.Strike = msoNoStrike
End With
Range("O27").Select
Range("A438:A505,F438:F505").Select
Range("F505").Activate
ActiveSheet.Shapes.AddChart2(216, xlBarClustered).Select
ActiveChart.SetSourceData Source:=Range( _
"Sheet1!$A$438:$A$505,Sheet1!$F$438:$F$505")
ActiveSheet.Shapes("Chart 2").IncrementLeft 312.75
ActiveSheet.Shapes("Chart 2").IncrementTop -61.5
ActiveChart.ChartTitle.Select
ActiveChart.ChartTitle.Text = "Aantal gebelde minuten (Internal)"
Selection.Format.TextFrame2.TextRange.Characters.Text = _
"Aantal gebelde minuten (Internal)"
With Selection.Format.TextFrame2.TextRange.Characters(1, 33).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 33).Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 14
.Italic = msoFalse
.Kerning = 12
.name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Spacing = 0
.Strike = msoNoStrike
End With
Range("M458").Select
Application.CommandBars("Format Object").Visible = False
Range("A507:A831,F507:F831").Select
Range("F831").Activate
ActiveSheet.Shapes.AddChart2(216, xlBarClustered).Select
ActiveChart.SetSourceData Source:=Range( _
"Sheet1!$A$507:$A$831,Sheet1!$F$507:$F$831")
ActiveSheet.Shapes("Chart 3").IncrementLeft 301.5
ActiveSheet.Shapes("Chart 3").IncrementTop -73.5
ActiveChart.ChartTitle.Select
Application.CommandBars("Format Object").Visible = False
ActiveChart.ChartTitle.Text = "Aantal gebelde minuten (Outbound)"
Selection.Format.TextFrame2.TextRange.Characters.Text = _
"Aantal gebelde minuten (Outbound)"
With Selection.Format.TextFrame2.TextRange.Characters(1, 33).ParagraphFormat
.TextDirection = msoTextDirectionLeftToRight
.Alignment = msoAlignCenter
End With
With Selection.Format.TextFrame2.TextRange.Characters(1, 33).Font
.BaselineOffset = 0
.Bold = msoFalse
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(89, 89, 89)
.Fill.Transparency = 0
.Fill.Solid
.Size = 14
.Italic = msoFalse
.Kerning = 12
.name = "+mn-lt"
.UnderlineStyle = msoNoUnderline
.Spacing = 0
.Strike = msoNoStrike
End With
Range("P535").Select
ActiveWindow.SmallScroll Down:=-18
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Parent.Cut
Sheets("Sheet1").Select
Sheets("Sheet1").name = "Log"
Sheets.Add After:=ActiveSheet
Sheets("Sheet1").Select
Sheets("Sheet1").name = "Chart"
Range("A1").Select
ActiveSheet.Paste
Sheets("Log").Select
ActiveSheet.ChartObjects("Chart 2").Activate
ActiveChart.Parent.Cut
Sheets("Chart").Select
Range("J1").Select
ActiveSheet.Paste
Sheets("Log").Select
ActiveSheet.ChartObjects("Chart 3").Activate
ActiveChart.Parent.Cut
Sheets("Chart").Select
Range("E19").Select
ActiveSheet.Paste
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.Shapes("Chart 1").ScaleWidth 1.1479166667, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes("Chart 1").ScaleHeight 1.1770833333, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.ChartObjects("Chart 2").Activate
ActiveSheet.ChartObjects("Chart 2").Activate
ActiveSheet.Shapes("Chart 2").ScaleWidth 1.1416666667, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes("Chart 2").ScaleHeight 1.1736111111, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.ChartObjects("Chart 3").Activate
ActiveSheet.ChartObjects("Chart 3").Activate
ActiveSheet.Shapes("Chart 3").ScaleWidth 1.1979166667, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes("Chart 3").ScaleHeight 1.2361111111, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.ChartObjects("Chart 3").Activate
ActiveChart.PlotArea.Select
Selection.Left = 85.964
Selection.Top = 37.09
ActiveChart.ChartArea.Select
ActiveSheet.Shapes("Chart 3").IncrementLeft 36
ActiveSheet.Shapes("Chart 3").IncrementTop -0.75
Sheets("Log").Select
End Sub
Right-click the dropdown box on the form and select "View Code". In the right top corner of the screen select "Change" event and use the code below:
Private Sub ComboBox1_Change()
Dim WbSource As Workbook
Dim pth As String
Dim fnme As String
fnme = ComboBox1.Value
pth = "C:\Users\Test\Desktop\Macro's\"
Application.Run "CustomMacro", pth & fnme
End Sub
If the answer works, please mark as accepted.
I understand that you need to run a macro on the opened workbook now. This can be done in a few ways, here is my suggestion to solve the problem:
1) Try to stay away from ThisWorkbook and ActiveWorksheet - use variables that are dimensioned as workbooks and worksheets
2) You can pass variables to the macro in several ways - you can make a variable global (I suggest you read up on different levels of variables), but the easiest way is to make the variable an argument for the function.
3) For my solution, I will assume you have two workbooks each with one sheet. I will call them target and source: source is the workbook selected from dropdown menu, and the target is the one where the macro is located. The dropdown box will remember the path to the source and will pass it on to the other macro.
Sub CustomMacro(SrceWBPath as String)
Dim WbSource as workbook
Dim WbTarget as workbook
Dim WrkShtSrc as Worksheet
Dim WrkShtTrgt as Worksheet
Set WbTarget = This.Workbook
Set WbSource = Workbooks.Open (SrceWbPath)
Set WrkShtSrc = wbSource.Worksheets("insert_name_of_the_source_worksheet_here")
Set WrkShtTrgt = wbTarget.Worksheets("insert_name_of_the_target_worksheet_here")
'Then insert the rest of your code here, calling the proper sheets as required. Also, move away from `.Select` command - it just consumes a lot of processing time. Define variable such as `Range` and perform operations on them.
End Sub
I need to create charts from CSV-files. This happens every day, for quite a few tables, so I automated it.
When the CSV files are created, they're stored in the folder from that day.
When I open my VBA script it'll read all the CSV files in that folder, and paste all the tables (each on a new sheet, obviously) together in a new workbook.
With NewBook
Set sv = .Sheets.Add(After:=.Sheets(i))
sv.Name = SvName
< Add CSV-files to just created sheet >
With sv
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
Debug.Print SvName & ":" & vbTab & "Cells(" & LastRow; ", " & LastColumn & ")"
End With
Set svChart = .Sheets.Add(After:=.Sheets(SvName))
svChart.Name = SvName & " Chart"
With svChart
.Shapes.AddChart.Name = SvName & "-cht"
With .Shapes(SvName & "-cht")
.Left = Range("A1").Left
.Top = Range("A1").Top
.Width = Range("A1:AC56").Width
.Height = Range("A1:AC56").Height
End With
End With
End With
The code above works fine, but is only drawing the parent of the chart. all options i found which supposed to make it a line chart, for example
ActiveChart.ChartType = xlLine
and for the range
ActiveChart.SetSourceData Source:=Range(Cells(2, "A"), Cells(LastRow, LastColumn))
result in an error like
"With not set"
or
"This option is not available for this object"
You need to reference the chart that you create with AddChart :
With your code :
Dim oChart As Chart
Set oChart = .Shapes.AddChart
oChart.Name = SvName & "-cht"
oChart.ChartType = xlLine
oChart.SetSourceData Source:=Range(Cells(2, "A"), Cells(LastRow, LastColumn))
With my code (without Shapes) :
Dim oChart As Chart
Set oChart = ActiveWorkbook.Charts.Add
oChart.Name = SvName & "-cht"
oChart.ChartType = xlLine
oChart.SetSourceData Source:=Range(Cells(2, "A"), Cells(LastRow, LastColumn))
##
Here is your full code with the implemantation that I proposed :
Dim oChart As Chart
With NewBook
Set sv = .Sheets.Add(After:=.Sheets(i))
sv.Name = SvName
'< Add CSV-files to just created sheet >
With sv
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
Debug.Print SvName & ":" & vbTab & "Cells(" & LastRow; ", " & LastColumn & ")"
End With
Set svChart = .Sheets.Add(After:=.Sheets(SvName))
svChart.Name = SvName & " Chart"
With svChart
Set oChart = ActiveWorkbook.Charts.Add
'oChart.Select
oChart.Name = SvName & "-cht"
oChart.ChartType = xlLine
oChart.SetSourceData Source:=Range(Cells(2, "A"), Cells(LastRow, LastColumn))
With .Shapes(SvName & "-cht")
.Left = Range("A1").Left
.Top = Range("A1").Top
.Width = Range("A1:AC56").Width
.Height = Range("A1:AC56").Height
End With
End With
End With
Here is what I use when I want to create a Chart in Excel :
Sub Graph()
Dim Gr As Chart, _
Sr As Series, _
Src_Name As String
Src_Name = "Sheet1"
Set Gr = ActiveWorkbook.Charts.Add
With Gr
'----Source Data Definition
.SetSourceData Source:=Range(Sheets(Src_Name).Cells(2, 1), Sheets(Src_Name).Cells(1197, 2)), PlotBy:=xlColumns
'----Graph Type
.ChartType = xlXYScatterSmoothNoMarkers
'----Location/Placement
.Location Where:=xlLocationAsNewSheet, Name:="NewSheetName"
'----Title
.HasTitle = True
.ChartTitle.Characters.Text = "Chart Title"
'----Data Series 1
Set Sr = .SeriesCollection.NewSeries
With Sr
.Values = Range(Sheets(Src_Name).Cells(2, 2), Sheets(Src_Name).Cells(20, 5))
.XValues = Range(Sheets(Src_Name).Cells(2, 1), Sheets(Src_Name).Cells(20, 1))
.AxisGroup = 1
.Name = "MTTF"
End With
'----Data Series 2
Set Sr = .SeriesCollection.NewSeries
With Sr
.Values = Range(Sheets(Src_Name).Cells(2, 2), Sheets(Src_Name).Cells(20, 5))
.XValues = Range(Sheets(Src_Name).Cells(2, 1), Sheets(Src_Name).Cells(20, 1))
.Name = "MTTR"
'----Placing a Serie on Second axis
.AxisGroup = 2
End With
'----Series' formats
'.SeriesCollection(i).Delete
'----For a line type chart
'.SeriesCollection(i).Format.Line.Weight = 1
'.SeriesCollection(i).Format.Line.ForeColor.RGB = RGB(int1 as integer, int1 as integer, int3 as integer)
'----For an area type chart
'.SeriesCollection(i).Format.Fill.ForeColor.RGB = RGB(int1 as integer, int1 as integer, int3 as integer)
'----Axis parameters
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Age"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Hours"
.PlotArea.Interior.ColorIndex = 2
.Axes(xlValue).MajorGridlines.Border.LineStyle = xlDot
.ChartArea.Font.Size = 14
.Deselect
'----Legend positioning
With .Legend
.Left = 350
.Top = 75
End With
'----Drawing area positiong
With .PlotArea
.Width = 550
.Height = 350
End With
End With
'----Free memory
Set Gr = Nothing
Set Sr = Nothing
End Sub
I found a macro online that creates a Statistical Quality Control chart online. So I have a .Csv file that looks like an excel sheet. I use the macro, so I have to select the data points. Then I have to select the labels, and then it gets plotted.
So instead of calculating the standard deviation from the selected data as my macro does, I want it to calculate the Upper limits and Lower limits from a set Standard deviation. Which is in the cell "F3". I have tried creating a variant where "stddev=Range("F3").value" But when I included it in my macro, the data was scattered and my labels on the right were not showing up as they were before. I will specify , where in the code that I think the problem is lying.
Here is the full code for creating the Quality control chart:
Option Explicit
Public Function GetRange(box_message As String) As Range
Set GetRange = Nothing
On Error Resume Next
Set GetRange = Application.InputBox(box_message, "Select Range", Selection.Address, , , , , 8)
End Function
Public Function IsNotOk(ByVal rng As Range) As Boolean 'TO CHECK IF A GIVEN RANGE IS BLANK
IsNotOk = True
On Error GoTo if_error_occured:
If rng.Rows.Count > 0 And rng.Columns.Count = 1 Then IsNotOk = False
if_error_occured:
If Err.Number Then IsNotOk = True
End Function
Public Function check_if_numeric(rng As Range) As Boolean
Dim cel As Range
check_if_numeric = True
For Each cel In rng.Cells
If Not (Application.WorksheetFunction.IsNumber(cel.Value)) Then check_if_numeric = False
Next cel
End Function
Sub Make_Control_Chart()
Dim data_values As Range
Dim chart_labels As Range
Dim range_selected_before As Range
Dim got_label_range As Boolean
Dim got_value_range As Boolean
Dim bActivate As Boolean
Dim myChtObj As ChartObject
Dim plot_series, MyNewSrs As Series
Dim series_label As String
Dim number_of_control_limits As Integer
Dim standard_deviation As Integer
Dim data_str As String
Dim avg_str As String
Dim stddev As Variant
On Error GoTo if_error_occured: 'GOTO THE END OF THE PROGRAM
stddev = Range("F3").Value
'GET RANGE FOR DATA VALUES
bActivate = False ' True to re-activate the input range
Set data_values = GetRange("Please select the range containing the DATA POINTS" & Chr(13) & "(press select a single column)")
If IsNotOk(data_values) Then
MsgBox "Incorrect Input Data !"
End
ElseIf Not (check_if_numeric(data_values)) Then
MsgBox "Incorrect Input Data !"
End
End If
'GET RANGE FOR CHART X-AXIS LABELS
got_label_range = True ' True to re-activate the input range
Set chart_labels = GetRange("Please select the range containing the LABELS" & Chr(13) & "(press ESC if no labels available)")
If IsNotOk(chart_labels) Then
got_label_range = False
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'LETS CREATE THE CHART NOW
Set myChtObj = ActiveSheet.ChartObjects.Add(Left:=300, Width:=450, Top:=25, Height:=300)
myChtObj.Chart.ChartType = xlLineMarkers
'REMOVE ALL UNWANTED SERIES FROM CHART, IF ANY
For Each MyNewSrs In myChtObj.Chart.SeriesCollection ' myChtObj.Chart.SeriesCollection
MyNewSrs.Delete
Next MyNewSrs
Set MyNewSrs = Nothing
If got_label_range Then 'IF WE HAVE THE LABEL RANGE
'ADD NEW SERIES
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = "PLOT"
.Values = data_values
.XValues = chart_labels.Value
End With
Else
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = "PLOT"
.Values = data_values
End With
End If
'FORMAT THE PLOT SERIES
Set plot_series = MyNewSrs
With MyNewSrs
.Border.ColorIndex = 1
.MarkerBackgroundColorIndex = 2
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlCircle
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
Set MyNewSrs = Nothing
'CREATE NAMED RANGE FOR THE DATA VALUES, AVERAGE, LOWER AND UPPER CONTROL LIMITS
data_str = Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values"
avg_str = "roundup(average(" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values" & "),2)"
'HERE THE LIMITS ARE SET AND THE ORIGINAL CODE IS SET IN THERE WHERE IT WORKS ON A SET OF DATA POINTS, HOWEVER WHEN I TRY TO CHANGE IT TO JUST "1*stddev,3" the data gets all scattered. I'M WONDERING WHY THE DATA IS BEING SCATTERED?
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values", RefersToR1C1:=data_values
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_AVG", RefersToR1C1:="=" & avg_str & ""
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL1", RefersToR1C1:="=" & avg_str & "- roundup(1*stdev(" & data_str & "),3)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL2", RefersToR1C1:="=" & avg_str & "- roundup(2*stdev(" & data_str & "),3)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL3", RefersToR1C1:="=" & avg_str & "- roundup(3*stdev(" & data_str & "),3)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL1", RefersToR1C1:="=" & avg_str & "+ roundup(1*stdev(" & data_str & "),3)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL2", RefersToR1C1:="=" & avg_str & "+ roundup(2*stdev(" & data_str & "),3)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL3", RefersToR1C1:="=" & avg_str & "+ roundup(3*stdev(" & data_str & "),3)"
The code for formatting and creating the lines on the chart:
'ADD THE LINE FOR AVERAGE
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = "AVG = "
.Values = "='" & ActiveSheet.Name & "'!" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_AVG"
.ChartType = xlXYScatter
'.ErrorBar Direction:=xlX, Include:=xlNone, Type:=xlFixedValue, Amount:=10000
'.ErrorBar Direction:=xlX, Include:=xlUp, Type:=xlFixedValue, Amount:=20
.ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count
.MarkerBackgroundColorIndex = xlAutomatic
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlNone
.Smooth = False
.MarkerSize = 5
.Shadow = False
With .Border
.Weight = xlHairline
.LineStyle = xlNone
End With
'With .ErrorBars.Border
' .LineStyle = xlContinuous
' .ColorIndex = 3
' .Weight = xlThin
'End With
End With
Set MyNewSrs = Nothing
'ADD UPPER AND LOWER CONTROL LIMITS
For number_of_control_limits = 1 To 3
For standard_deviation = -1 To 1 Step 2
Select Case standard_deviation:
Case -1: series_label = "LCL"
Case 1: series_label = "UCL"
End Select
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = series_label & number_of_control_limits & " ="
.Values = "='" & ActiveSheet.Name & "'!" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_" & series_label & number_of_control_limits
.ChartType = xlXYScatter
.ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count
End With
MyNewSrs.ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count
Select Case number_of_control_limits:
Case 1:
With MyNewSrs.ErrorBars.Border
.LineStyle = xlGray25
.ColorIndex = 15
.Weight = xlHairline
End With
Case 2:
With MyNewSrs.ErrorBars.Border
.LineStyle = xlGray25
.ColorIndex = 57
.Weight = xlHairline
End With
Case 3:
With MyNewSrs.ErrorBars.Border
.LineStyle = xlGray75
.ColorIndex = 3
.Weight = xlHairline
End With
End Select
MyNewSrs.ErrorBars.EndStyle = xlNoCap
With MyNewSrs
With .Border
.Weight = xlHairline
.LineStyle = xlNone
End With
.MarkerBackgroundColorIndex = xlAutomatic
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlNone
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
Set MyNewSrs = Nothing
Next standard_deviation
Next number_of_control_limits
myChtObj.Chart.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=False, ShowSeriesName:=True, ShowCategoryName:=False, _
ShowValue:=True, ShowPercentage:=False, ShowBubbleSize:=False, Separator:=" "
'OFFSET THE LABELS
For Each MyNewSrs In myChtObj.Chart.SeriesCollection
With MyNewSrs.Points(1).DataLabel
.Left = 400
End With
Next MyNewSrs
'LETS FORMAT THE CHART
With myChtObj
With .Chart.Axes(xlCategory)
.MajorTickMark = xlNone
.MinorTickMark = xlNone
.TickLabelPosition = xlNextToAxis
End With
With .Chart.Axes(xlValue)
.MajorTickMark = xlOutside
.MinorTickMark = xlNone
.TickLabelPosition = xlNextToAxis
End With
With .Chart.ChartArea.Border
.Weight = 1
.LineStyle = 0
End With
With .Chart.PlotArea.Border
.ColorIndex = 1
.Weight = xlThin
.LineStyle = xlContinuous
End With
With .Chart.PlotArea.Interior
.ColorIndex = 2
.PatternColorIndex = 1
.Pattern = xlSolid
End With
With .Chart.ChartArea.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With
With .Chart
.HasTitle = False
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = True
.HasTitle = True
.ChartTitle.Characters.Text = "Control Chart"
.ChartTitle.Left = 134
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Observations"
End With
With .Chart.Axes(xlCategory).TickLabels
.Alignment = xlCenter
.Offset = 100
.ReadingOrder = xlContext
.Orientation = xlHorizontal
End With
End With
myChtObj.Chart.Legend.Delete
myChtObj.Chart.PlotArea.Width = 310
myChtObj.Chart.Axes(xlValue).MajorGridlines.Delete
myChtObj.Chart.Axes(xlValue).CrossesAt = myChtObj.Chart.Axes(xlValue).MinimumScale
myChtObj.Chart.ChartArea.Interior.ColorIndex = xlAutomatic
myChtObj.Chart.ChartArea.AutoScaleFont = True
'DELETE THE LABELS FOR THE ACTUAL DATA SERIES
plot_series.DataLabels.Delete
Set plot_series = Nothing
if_error_occured:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number Then z_delete_all_named_range
End Sub
Sub z_delete_all_named_range()
Dim nam As Name
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
For Each nam In ActiveWorkbook.Names
nam.Delete
Next nam
End Sub
Compiled but not tested:
Sub Make_Control_Chart()
Dim data_values As Range
Dim chart_labels As Range
Dim range_selected_before As Range
Dim got_label_range As Boolean
Dim got_value_range As Boolean
Dim bActivate As Boolean
Dim myChtObj As ChartObject
Dim plot_series, MyNewSrs As Series
Dim series_label As String
Dim number_of_control_limits As Integer
Dim standard_deviation As Integer
Dim data_str As String
Dim avg_str As String
Dim stddev As Variant
Dim wb As Workbook, sCht As String, i As Long
Set wb = ActiveWorkbook
'On Error GoTo if_error_occured: 'GOTO THE END OF THE PROGRAM
stddev = Range("F3").Value
'GET RANGE FOR DATA VALUES
bActivate = False ' True to re-activate the input range
Set data_values = GetRange("Please select the range containing the DATA POINTS" & _
Chr(13) & "(press select a single column)")
If IsNotOk(data_values) Then
MsgBox "Incorrect Input Data !"
Exit Sub 'not End!
ElseIf Not (check_if_numeric(data_values)) Then
MsgBox "Incorrect Input Data !"
Exit Sub 'not End!
End If
'GET RANGE FOR CHART X-AXIS LABELS
got_label_range = True ' True to re-activate the input range
Set chart_labels = GetRange("Please select the range containing the LABELS" & _
Chr(13) & "(press ESC if no labels available)")
If IsNotOk(chart_labels) Then
got_label_range = False
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'LETS CREATE THE CHART NOW
Set myChtObj = ActiveSheet.ChartObjects.Add(Left:=300, Width:=450, _
Top:=25, Height:=300)
myChtObj.Chart.ChartType = xlLineMarkers
'REMOVE ALL UNWANTED SERIES FROM CHART, IF ANY
For Each MyNewSrs In myChtObj.Chart.SeriesCollection
MyNewSrs.Delete
Next MyNewSrs
Set MyNewSrs = Nothing
'IF WE HAVE THE LABEL RANGE
'ADD NEW SERIES
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = "PLOT"
.Values = data_values
If got_label_range Then
.XValues = chart_labels.Value
End If
End With
'FORMAT THE PLOT SERIES
Set plot_series = MyNewSrs
With MyNewSrs
.Border.ColorIndex = 1
.MarkerBackgroundColorIndex = 2
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlCircle
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
Set MyNewSrs = Nothing
'CREATE NAMED RANGE FOR THE DATA VALUES, AVERAGE, LOWER AND UPPER CONTROL LIMITS
sCht = sCht
data_str = sCht & "_data_values"
avg_str = "roundup(average(" & sCht & "_data_values" & "),2)"
wb.Names.Add Name:=sCht & "_data_values", RefersToR1C1:=data_values
wb.Names.Add Name:=sCht & "_AVG", RefersToR1C1:="=" & avg_str & ""
For i = 1 To 3
wb.Names.Add Name:=sCht & "_LCL" & i, _
RefersToR1C1:="=" & avg_str & "- roundup(" & i & "*" & stddev & ",3)"
wb.Names.Add Name:=sCht & "_UCL" & i, _
RefersToR1C1:="=" & avg_str & "+ roundup(" & i & "*" & stddev & ",3)"
Next i
End Sub
Public Function GetRange(box_message As String) As Range
On Error Resume Next
Set GetRange = Application.InputBox(box_message, "Select Range", Selection.Address, , , , , 8)
End Function
Public Function IsNotOk(ByVal rng As Range) As Boolean 'TO CHECK IF A GIVEN RANGE IS BLANK
IsNotOk = True
On Error GoTo if_error_occured:
If rng.Rows.Count > 0 And rng.Columns.Count = 1 Then IsNotOk = False
if_error_occured:
If Err.Number Then IsNotOk = True
End Function
Public Function check_if_numeric(rng As Range) As Boolean
Dim cel As Range, rv As Boolean
rv = True
For Each cel In rng.Cells
If Not (Application.WorksheetFunction.IsNumber(cel.Value)) Then
rv = False
Exit For
End If
Next cel
check_if_numeric = rv
End Function