At work I have excel 2013 and I have a for cicle that add new data to the series of a chart at every iteration.
It works flawlessly and at every iteration I can see the chart updating.
Now I tried the code on my home pc with excel 2016 and no matter what the chart won't update. I tried everything
dim chr as ChartObject
dim chrt as Chart
set chr = Sheet1.ChartObjects.Add
set chrt = chr.Chart
then I tried everything like
doevents
chr.refresh
sheet1.enablecalculation = true
application.screenupdating = true
chr.activate
Application.ontime Now + timeSerial(0,0,1), "wt"
sub wt
Application.wait + timeSerial(0,0,1)
end sub
anything you can think of .. it won't update
Any suggestion? thanks to everyone
EDIT: I found that it works if I add
Sheet1.ResetAllPageBreaks
at the end of each iteration, BUT it slows down the code too much
Sub risolutore()
Application.ScreenUpdating = True
' DICHIARAZIONE DELLE VARIABILI
Dim ws As Worksheet
Dim chr As ChartObject, chr2 As ChartObject
Dim rng As Range, rng2 As Range
Dim grafico As Chart, grafico2 As Chart
'''''''''''''''''''''''''''''''
' SHEET SETTING
Set ws = Foglio5
''''''''''''''''
For Each ch In ws.ChartObjects
ch.Delete
Next ch
'SETTAGGIO DELLE CELLE DI RIFERIMENTO'''''''''''
w_cells = ws.Range("B2:B9").Address
v_cell = ws.Range("B16").Address
s_cell = ws.Range(v_cell).Offset(1, 0).Address
m_cell = ws.Range(v_cell).Offset(2, 0).Address
sum_cell = ws.Range(v_cell).Offset(3, 0).Address
s_col = "F"
wci = "H"
wcf = "O"
nri = 14
ndati = 40
nrf = nri + ndati - 1
m_max = Application.WorksheetFunction.Max(ws.Range(w_cells).Offset(0, 1))
ws.Range(s_col & nri & ":" & wcf & nrf).ClearContents
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
DoEvents
' CICLO RISOLUTORE E GRAFICI
For i = nri To nrf
ws.EnableCalculation = False
ws.EnableCalculation = True
' MIN VAR PORTFOLIO
If i = nri Then
' SETTAGGI DEL RISOLUTORE PER IL MIN VAR PORTFOLIO
obj = ws.Range(s_col & i).Offset(0, 1).Address
'reset dei parametri del solver
Application.Run "Solver.xlam!SolverReset"
'Decido la funzione da ottimizzare
Application.Run "Solver.xlam!SolverOk", v_cell, 2, 0, w_cells, 1, "GRG Nonlinear"
' vincolo di rendimento atteso
'Application.Run "Solver.xlam!SolverAdd", m_cell, 2, obj
' vincolo di peso maggiore di 0
Application.Run "Solver.xlam!SolverAdd", w_cells, 3, "0"
' vincolo di peso minore di 1
Application.Run "Solver.xlam!SolverAdd", w_cells, 1, "=1"
' vincolo di somma pesi uguale a 1
Application.Run "Solver.xlam!SolverAdd", sum_cell, 2, "=1"
Application.Run "Solver.xlam!SolverOptions", , , , , , , , , , , , False
' avvio il solver
Application.Run "Solver.xlam!SolverSolve", True
ws.Range(s_col & i).Value = ws.Range(s_cell).Value
ws.Range(s_col & i).Offset(0, 1).Value = ws.Range(m_cell).Value
ws.Range(s_col & i).NumberFormat = "0.000%"
ws.Range(s_col & i).Offset(0, 1).NumberFormat = "0.000%"
ws.Range(wci & i & ":" & wcf & i).Value = Application.WorksheetFunction.Transpose(ws.Range(w_cells).Value)
ws.Range(wci & i & ":" & wcf & i).NumberFormat = "0.00%"
' DETERMINO I VALORI DEI RENDIMENTI PER IL GRAFICO
m_min = ws.Range(m_cell).Value
max_min = m_max - m_min
Dim v() As Variant
ReDim v(1 To ndati)
v(1) = m_min
For K = LBound(v) + 1 To UBound(v)
v(K) = v(K - 1) + max_min / (ndati - 1)
Next K
ws.Range(s_col & nri).Offset(0, 1).Resize(UBound(v) - LBound(v) + 1).Value = Application.WorksheetFunction.Transpose(v)
ws.Range(s_col & nri).Offset(0, 1).Resize(UBound(v) - LBound(v) + 1).NumberFormat = "0.000%"
' SETTAGGI DEL PRIMO GRAFICO
Set rng = ws.Range("Q13:V25")
Set chr = ws.ChartObjects.Add(Left:=rng.Left, Width:=rng.Width, Top:=rng.Top, Height:=rng.Height)
Set grafico = chr.Chart
grafico.ChartType = xlXYScatterSmooth
grafico.SeriesCollection.NewSeries
grafico.SeriesCollection(1).XValues = ws.Range(s_col & nri).Offset(0, 0)
grafico.SeriesCollection(1).Values = ws.Range(s_col & nri).Offset(0, 1)
grafico.Axes(xlCategory).MinimumScale = ws.Range(s_col & nri).Offset(0, 0) * 0.8
grafico.Axes(xlCategory).TickLabels.Orientation = 35
grafico.Axes(xlValue).MinimumScale = m_min * 0.9
grafico.Axes(xlValue).MaximumScale = m_max * 1.1
grafico.Legend.Delete
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SETTAGGI DEL SECONDO GRAFICO
Set rng2 = ws.Range("Q26:V42")
Set chr2 = ws.ChartObjects.Add(Left:=rng2.Left, Width:=rng2.Width, Top:=rng2.Top, Height:=rng2.Height)
Set grafico2 = chr2.Chart
grafico2.ChartType = xlAreaStacked100
grafico2.HasTitle = False
grafico2.Legend.Position = xlLegendPositionBottom
grafico2.Axes(xlValue).MinimumScale = 0
For j = 1 To 8
grafico2.SeriesCollection.NewSeries
grafico2.SeriesCollection(j).XValues = ws.Range(s_col & nri & ":" & s_col & nri)
grafico2.SeriesCollection(j).Values = ws.Range(s_col & nri & ":" & s_col & nri).Offset(0, 2 + j - 1)
grafico2.SeriesCollection(j).Name = ws.Range(s_col & nri).Offset(-2, 2 + j - 1)
Next j
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DETERMINO GLI ALTRI PORTAFOGLI EFFICIENTI
ElseIf i > nri Then
If i = nri + 1 Then
grafico.ChartType = xlXYScatterSmoothNoMarkers
End If
obj = ws.Range(s_col & i).Offset(0, 1).Address
'reset dei parametri del solver
Application.Run "Solver.xlam!SolverReset"
'Decido la funzione da ottimizzare
Application.Run "Solver.xlam!SolverOk", v_cell, 2, 0, w_cells, 1, "GRG Nonlinear"
' vincolo di rendimento atteso
Application.Run "Solver.xlam!SolverAdd", m_cell, 2, obj
' vincolo di peso maggiore di 0
Application.Run "Solver.xlam!SolverAdd", w_cells, 3, "0"
' vincolo di peso minore di 1
Application.Run "Solver.xlam!SolverAdd", w_cells, 1, "=1"
' vincolo di somma pesi uguale a 1
Application.Run "Solver.xlam!SolverAdd", sum_cell, 2, "=1"
Application.Run "Solver.xlam!SolverOptions", , , , , , , , , , , , False
' avvio il solver
Application.Run "Solver.xlam!SolverSolve", True
ws.Range(s_col & i).Value = ws.Range(s_cell).Value
ws.Range(s_col & i).NumberFormat = "0.000%"
ws.Range(wci & i & ":" & wcf & i).Value = Application.WorksheetFunction.Transpose(ws.Range(w_cells).Value)
ws.Range(wci & i & ":" & wcf & i).NumberFormat = "0.00%"
grafico.SeriesCollection(1).XValues = ws.Range(s_col & nri & ":" & s_col & i)
grafico.SeriesCollection(1).Values = ws.Range(s_col & nri & ":" & s_col & i).Offset(0, 1)
For j = 1 To 8
grafico2.SeriesCollection(j).XValues = ws.Range(s_col & nri & ":" & s_col & nrf)
grafico2.SeriesCollection(j).Values = ws.Range(s_col & nri & ":" & s_col & i).Offset(0, 2 + j - 1)
Next j
End If
Next i
Application.ScreenUpdating = True
MsgBox "Ottimizazione Completata", vbInformation
End Sub
Have you tried just changing the chart data?
I worked with charts and when i changed the data the chart changed instantly.
Related
I want to make a dropdown that only contains 5/10 sheets that when i click on the sheet from the dropdown it proceeds to the sheet. At the moment I have a dropdown with all the sheets in it although I don't want them all.
Hopefully someone understands. Please feel free to ask for more information.
Thanks
This needs to be pasted on the sheet where the cell will change (not in a module). Be sure to swap "Sheet5" and "A2" in the code to the sheet name and cell range on your excel.
Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, ThisWorkbook.Sheets("Sheet5").Range("A2")) Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error GoTo Stopsub:
Call ChangeSheet
Stopsub:
Application.EnableEvents = True
End Sub
Sub ChangeSheet()
Dim SelectedSheet As String
SelectedSheet = ThisWorkbook.Sheets("Sheet5").Range("A2")
ThisWorkbook.Sheets(SelectedSheet).Activate
End Sub
This is a slightly different concept, which uses hyperlinks to navigate through a workbook. Hope it helps you out.
Sub BuildTOC_A3()
Cells(3, 1).Select
BuildTOC
End Sub
Sub BuildTOC()
'listed from active cell down 7-cols -- DMcRitchie 1999-08-14 2000-09-05
Dim iSheet As Long, iBefore As Long
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Long
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
mg = ""
CRLF = Chr(10) 'Actually just CR
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 + ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" & CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not $$TOC" & CRLF
If mg <> "" Then
mg = "Warning BuildTOC will destructively rewrite the selected area" _
& CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
& "the affected area will be rewritten, or" & CRLF & _
"Press CANCEL to check area then reinvoke this macro (BuildTOC)"
Application.ScreenUpdating = True 'make range visible
Reply = MsgBox(mg, vbOKCancel, "Create TOC for " & ActiveWorkbook.Sheets.Count _
& " items in workbook" & Chr(10) & "revised will now occupy up to 10 columns")
Application.ScreenUpdating = False
If Reply <> 1 Then GoTo AbortCode
End If
rg.Clear 'Clear out any previous hyperlinks, fonts, etc in the area
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
'hypName = "'" & Sheets(csht).Name
' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace not in XL97
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8# Then
'-- use next line for XL95
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name 'XL95
Else
'-- Only for XL97, XL98, XL2000 -- will create hyperlink & codename
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).CodeName
'--- excel is not handling lots of objects well ---
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht, cCol), _
' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
'--- so will use the HYPERLINK formula instead ---
'--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
Else
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
End If
Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
' -- activate next line to include content of cell A1 for each sheet
' Cells(cRow - 1 + csht, cCol + 3) = Sheets(Sheets(csht).Name).Range("A1").Value
On Error Resume Next
Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea '.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 7) = Sheets(cSht).PageSetup.PrintArea
If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
On Error GoTo 0
Next cSht
'Now sort the results: 2. Type(D), 1. Name (A), 3. module(unsorted)
rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending, Key2:=rg.Cells(1, 1) _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
rg.Columns.AutoFit
rg.Select 'optional
'if cells above range are blank want these headers
' Worksheet, Type, codename
If cRow > 1 Then
If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) & Cells(cRow - 1, cCol + 2)) Then
Cells(cRow - 1, cCol) = "Worksheet"
Cells(cRow - 1, cCol + 1) = "Type"
Cells(cRow - 1, cCol + 2) = "CodeName"
Cells(cRow - 1, cCol + 3) = "[opt.]"
Cells(cRow - 1, cCol + 4) = "Lastcell"
Cells(cRow - 1, cCol + 5) = "cells"
Cells(cRow - 1, cCol + 6) = "ScrollArea"
Cells(cRow - 1, cCol + 7) = "PrintArea"
End If
End If
Application.ScreenUpdating = True
Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
"Would you like the tabs in workbook also sorted", _
vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
& " tabs in workbook")
Application.ScreenUpdating = False
'If Reply = 1 Then SortALLSheets 'Invoke macro to Sort Sheet Tabs
Sheets(sSheetName).Activate
AbortCode:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I tried to 1) Centre and underline the Column E and F in Order List sheet, from line 22 up to the blank line. 2) Bold and centre the VAT and Total in the spreadsheet. 3) Clear Column G28 afterwards in the other sheets after generate Order List. However, it is not underlined or centralised or bolded. Could you please take a look for me? Here is my code below. Many thanks
Option Explicit
Sub copy_info()
Dim i As Long, j As Long, lastRow As Long
Dim sh As Worksheet
With Sheets("Order List")
.Cells.Clear
.Range("A21") = "PART CODE"
.Range("B21") = "DESCRIPTION"
.Range("C21") = "PRICE"
.Range("D21") = "QUANTITY"
.Range("E21") = "NET AMOUNT"
.Range("F21") = "SHEET NAME"
.Range("A21:F21").Font.Bold = True
End With
j = 22
For Each sh In ActiveWorkbook.Sheets
If sh.Name <> "Order List" And sh.Name <> "INDEX" And sh.Name <> "SELECTOR" Then
lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
For i = 28 To lastRow
If sh.Range("G" & i) > 0 Then
sh.Range("b" & i).Copy Destination:=Worksheets("Order List").Range("A" & j)
sh.Range("e" & i & ":g" & i).Copy Destination:=Worksheets("Order List").Range("B" & j)
Sheets("Order List").Range("E" & j) = Sheets("Order List").Range("C" & j) * Sheets("Order List").Range("D" & j)
Sheets("Order List").Range("F" & j) = sh.Name
Sheets("Order List").Range("B" & j + 1) = ""
Sheets("Order List").Range("B" & j + 2) = "VAT".bold.center
Sheets("Order List").Range("E" & j + 1) = ""
Sheets("Order List").Range("E" & j + 2) = Application.WorksheetFunction.Sum(Columns("E:E"))
Sheets("Order List").Range("B" & j + 3) = "TOTAL".bold.center Sheets("Order List").Range("E" & j + 3) = Application.WorksheetFunction.Sum(Columns("E:E"))
j = j + 1
End If
Next i
End If
Next sh
Sheets("Order List").Columns("A").AutoFit
Sheets("Order List").Columns("B").ColumnWidth = 90
Sheets("Order List").Columns("C:D").AutoFit
Sheets("Order List").Columns("E:F").AutoFit.Underline.Center
For Each sh In ActiveWorkbook.Sheets
If sh.Name <> "Order List" And sh.Name <> "INDEX" And sh.Name <> "SELECTOR" Then
lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
For i = 28 To lastRow
If sh.Range("G" & i) > 0 Then
sh.Range("G" & i).Select
Selection.ClearContents
End If
Next i
End If
Next sh
End Sub
That's a bit strange - you have Option Explicit on the top and thus your code should not be working at all, because of the compiling errors. The VBEditor should show you where they are exactly, once you try to run the code.
Here is one example:
In stead of:
Sheets("Order List").Range("B" & j + 2) = "VAT".bold.center
Write:
Sheets("Order List").Range("B" & j + 2).value = "VAT"
Sheets("Order List").Range("B" & j + 2).Font.Bold = True
Sheets("Order List").Range("B" & j + 2).HorizontalAlignment = xlCenter
Then you can improve it further like this:
With Sheets("Order List").Range("B" & j + 2)
.value = "VAT"
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
Or even write a separate function, to which you are passing only the range and the string.
You are trying to do everything at the same time(bold and center in the first part, center and underline at the bottom). This doesn't work in VBA. It is necessary to take just one action after another.
One possible solution to your problem could be this:
Sub copy_info()
Dim i As Long, j As Long, lastRow As Long
Dim sh As Worksheet
With Sheets("Order List")
.Cells.Clear
.Range("A21") = "PART CODE"
.Range("B21") = "DESCRIPTION"
.Range("C21") = "PRICE"
.Range("D21") = "QUANTITY"
.Range("E21") = "NET AMOUNT"
.Range("F21") = "SHEET NAME"
.Range("A21:F21").Font.Bold = True
End With
j = 22
For Each sh In ActiveWorkbook.Sheets
If sh.Name <> "Order List" And sh.Name <> "INDEX" And sh.Name <> "SELECTOR" Then
lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
For i = 28 To lastRow
If sh.Range("G" & i) > 0 Then
sh.Range("b" & i).Copy Destination:=Worksheets("Order List").Range("A" & j)
sh.Range("e" & i & ":g" & i).Copy Destination:=Worksheets("Order List").Range("B" & j)
Sheets("Order List").Range("E" & j) = Sheets("Order List").Range("C" & j) * Sheets("Order List").Range("D" & j)
Sheets("Order List").Range("F" & j) = sh.Name
Sheets("Order List").Range("B" & j + 1) = ""
Sheets("Order List").Range("B" & j + 2) = "VAT"
Sheets("Order List").Range("B" & j + 2).Font.Bold = True
Sheets("Order List").Range("B" & j + 2).HorizontalAlignment = xlCenter
Sheets("Order List").Range("E" & j + 1) = ""
Sheets("Order List").Range("E" & j + 2) = Application.WorksheetFunction.Sum(Columns("E:E"))
Sheets("Order List").Range("B" & j + 3) = "TOTAL"
**Sheets("Order List").Range("B" & j + 3).Font.Bold = True
Sheets("Order List").Range("B" & j + 3).HorizontalAlignment = xlCenter**
Sheets("Order List").Range("E" & j + 3) = Application.WorksheetFunction.Sum(Columns("E:E"))
j = j + 1
End If
Next i
End If
Next sh
Sheets("Order List").Columns("A").AutoFit
Sheets("Order List").Columns("B").ColumnWidth = 90
Sheets("Order List").Columns("C:D").AutoFit
Sheets("Order List").Columns("E:F").AutoFit
Sheets("Order List").Columns("E:F").HorizontalAlignment = xlCenter
Sheets("Order List").Columns("E:F").Font.Underline = xlUnderlineStyleSingle
For Each sh In ActiveWorkbook.Sheets
If sh.Name <> "Order List" And sh.Name <> "INDEX" And sh.Name <> "SELECTOR" Then
lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
For i = 28 To lastRow
If sh.Range("G" & i) > 0 Then
sh.Range("G" & i).Select
Selection.ClearContents
End If
Next i
End If
Next sh
End Sub
UPDATED:
Lastrow = .Range("C" & Rows.Count).End(xlUp).Row
DurcurrRowIn = currRowIn
Do
DurcurrRowIn = DurcurrRowIn + 1
Set DurlookFor = wb.ActiveSheet.Cells(currRowIn, "C") ' value to find
Set Durlookforin = wb.ActiveSheet.Range("C" & DurcurrRowIn & ":C" & Lastrow)
'Set Durlookforin = wb.ActiveSheet.Range("C:C")
On Error Resume Next
DurStart = Application.WorksheetFunction.Index(wb.ActiveSheet.Range("F" & DurcurrRowIn & ":F" & Lastrow), WorksheetFunction.Match(DurlookFor, Durlookforin, 0))
DurEnd = Application.WorksheetFunction.Index(wb.ActiveSheet.Range("G" & DurcurrRowIn & ":G" & Lastrow), WorksheetFunction.Match(DurlookFor, Durlookforin, 0))
DurStart = Format(DurStart, "mm-dd-yyyy")
Dur1 = DurEnd - DurStart
Dur = Dur + Dur1
Loop Until Durlookforin Is Nothing
Need help exiting the loop once all the employeeIDs have been found with the Index/Match
Here is a sample of my worksheet:
Test Excel
I have an excel file with 208 sheets and a summary sheet. Want to create a button to jump to each sheet. i am using the below codes for that.
Sub SearchSheetName()
Dim xName As String
Dim xFound As Boolean
xName = InputBox("Enter sheet name to find in workbook:", "Sheet search")
If xName = "" Then Exit Sub
On Error Resume Next
ActiveWorkbook.Sheets(xName).Select
xFound = (Err = 0)
On Error GoTo 0
If xFound Then
MsgBox "Sheet '" & xName & "' has been found and selected!"
Else
MsgBox "The sheet '" & xName & "' could not be found in this workbook!"
End If
End Sub
Going back to Summary sheet is difficult. so created macro with button
Private Sub CommandButton1_Click()
Sheets("SummarySheet").Select
End Sub
is there any easy way to create this button in all the sheets together.
I will add a button or shape (they are more pleasing in terms of cosmetics) to the sheet dynamically when its activated. Use Workbook's SheetActivate event to apply this to all the worksheets in the workbook.
In the WorkBook's SheetActivate add this
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Call addButton
End Sub
VBA code in a standard module:
Sub addButton()
'/ Dynamically add a semi-transparent shape on the active sheet.
'/ Call this inside workbooks SheetActivate event
Dim shp As Shape
Const strButtonName As String = "BackButton"
'/ Dont't add on summary sheet.
If ActiveSheet.Name = "Summary" Then Exit Sub
Application.ScreenUpdating = False
'/ Delete if old shape exists
For Each shp In ActiveSheet.Shapes
If shp.Name = strButtonName Then
shp.Delete
End If
Next
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 330.75, 36.75, 93.75, 29.25).Select
Selection.Name = "BackButton"
Set shp = ActiveSheet.Shapes(strButtonName)
'/ Some formatting for the shape.
With shp
.TextFrame.Characters.Text = "Summary"
.Top = 3
.Left = 3
.Fill.Transparency = 0.6
.Line.Visible = msoTrue
.Line.ForeColor.RGB = RGB(0, 112, 192)
.TextFrame2.VerticalAnchor = msoAnchorMiddle
'/ Add the macro to shape's click. This will active summary sheet.
shp.OnAction = "goBack"
End With
ActiveSheet.Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
Sub goBack()
ThisWorkbook.Worksheets("Summary").Select
End Sub
This sounds like a Table of Contents (TOC) question. Copy/paste the code below and see if it does essentially what you want.
Option Explicit
Sub Macro1()
Dim i As Integer
Dim TOC As String
Dim msg As String
Dim fc_order As Range
Dim fc_alphabet As Range
Dim sht As Object
TOC = "Table of Contents"
For i = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(i).Name = TOC Then
msg = Chr(10) & Chr(10) & "Your sheet " & Chr(10) & TOC & Chr(10) & "(now displayed) will be updated."
Worksheets(TOC).Activate
Exit For
Else
msg = "A new sheet will be added :" & TOC & ", with hyperlinks to all sheets in this workbook."
End If
Next i
If MsgBox(msg & Chr(10) & "Do you want to continue ?", 36, TOC) = vbNo Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If ActiveSheet.Name = TOC Then Worksheets(TOC).Delete
Worksheets(1).Activate
Worksheets.Add.Name = TOC
Cells.Interior.ColorIndex = 15
ActiveWindow.DisplayHeadings = False
With Cells(2, 6)
.Value = UCase(TOC)
.Font.Size = 18
.HorizontalAlignment = xlCenter 'verspreid over blad breedte
End With
Set fc_order = Cells(3, 4)
Set fc_alphabet = Cells(3, 8)
fc_order = "order of appearance"
For i = 2 To ActiveWorkbook.Worksheets.Count
If i Mod 30 = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=fc_order.Offset(i - 1, -2), Address:="", _
SubAddress:="'" & Worksheets(TOC).Name & "'!A1", TextToDisplay:="TOP"
End If
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 2, 4), Address:="", _
SubAddress:=Worksheets(i).Name & "!A1", TextToDisplay:=Worksheets(i).Name
Next i
fc_alphabet = "alphabetically"
Range(fc_order.Offset(1, 0), fc_order.End(xlDown)).Copy fc_alphabet.Offset(1, 0)
Range(fc_alphabet.Offset(1, 0), fc_alphabet.End(xlDown)).Sort Key1:=fc_alphabet.Offset(1, 0)
If MsgBox("Do you want a hyperlink to " & TOC & " on each sheet in cell A1 ?" & Chr(10) & _
"(if cell A1 is empty)", 36, "Hyperlink on each sheet") = vbYes Then
For Each sht In Worksheets
sht.Select
If Cells(1, 1) = "" And sht.Name <> TOC Then ActiveSheet.Hyperlinks.Add Anchor:=Cells(1, 1), Address:="", _
SubAddress:="'" & Worksheets(TOC).Name & "'!A1", TextToDisplay:="TOC"
Next sht
End If
Sheets(TOC).Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The script below is similar, but somewhat different, to the one above.
Sub BuildTOC()
'listed from active cell down 7-cols -- DMcRitchie 1999-08-14 2000-09-05
Dim iSheet As Long, iBefore As Long
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Long
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
mg = ""
CRLF = Chr(10) 'Actually just CR
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 + ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" & CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not $$TOC" & CRLF
If mg <> "" Then
mg = "Warning BuildTOC will destructively rewrite the selected area" _
& CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
& "the affected area will be rewritten, or" & CRLF & _
"Press CANCEL to check area then reinvoke this macro (BuildTOC)"
Application.ScreenUpdating = True 'make range visible
Reply = MsgBox(mg, vbOKCancel, "Create TOC for " & ActiveWorkbook.Sheets.Count _
& " items in workbook" & Chr(10) & "revised will now occupy up to 10 columns")
Application.ScreenUpdating = False
If Reply <> 1 Then GoTo AbortCode
End If
rg.Clear 'Clear out any previous hyperlinks, fonts, etc in the area
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
'hypName = "'" & Sheets(csht).Name
' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace not in XL97
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8# Then
'-- use next line for XL95
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name 'XL95
Else
'-- Only for XL97, XL98, XL2000 -- will create hyperlink & codename
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).CodeName
'--- excel is not handling lots of objects well ---
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht, cCol), _
' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
'--- so will use the HYPERLINK formula instead ---
'--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
Else
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
End If
Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
' -- activate next line to include content of cell A1 for each sheet
' Cells(cRow - 1 + csht, cCol + 3) = Sheets(Sheets(csht).Name).Range("A1").Value
On Error Resume Next
Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea '.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 7) = Sheets(cSht).PageSetup.PrintArea
If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
On Error GoTo 0
Next cSht
'Now sort the results: 2. Type(D), 1. Name (A), 3. module(unsorted)
rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending, Key2:=rg.Cells(1, 1) _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
rg.Columns.AutoFit
rg.Select 'optional
'if cells above range are blank want these headers
' Worksheet, Type, codename
If cRow > 1 Then
If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) & Cells(cRow - 1, cCol + 2)) Then
Cells(cRow - 1, cCol) = "Worksheet"
Cells(cRow - 1, cCol + 1) = "Type"
Cells(cRow - 1, cCol + 2) = "CodeName"
Cells(cRow - 1, cCol + 3) = "[opt.]"
Cells(cRow - 1, cCol + 4) = "Lastcell"
Cells(cRow - 1, cCol + 5) = "cells"
Cells(cRow - 1, cCol + 6) = "ScrollArea"
Cells(cRow - 1, cCol + 7) = "PrintArea"
End If
End If
Application.ScreenUpdating = True
Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
"Would you like the tabs in workbook also sorted", _
vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
& " tabs in workbook")
Application.ScreenUpdating = False
'If Reply = 1 Then SortALLSheets 'Invoke macro to Sort Sheet Tabs
Sheets(sSheetName).Activate
AbortCode:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub BuildTOC_A3()
Cells(3, 1).Select
BuildTOC
End Sub
I'm trying to plot huge series of data using for next statement. However, I don't know why the secondary axis is not being plotted by the following code:
Sub IndividualPlots()
Dim TF As Worksheet
Dim OIL As Worksheet
Dim WTR As Worksheet
Dim TG As Worksheet
Dim GL As Worksheet
Dim RG As Worksheet
Dim WC As Worksheet
Dim MM As Worksheet
Dim VRRStart As Worksheet
Dim NewWs As Worksheet
Dim cht As Chart
Dim chtobj As ChartObject
Dim Lastcol As Long
Dim Currcol As Long
Set TF = ThisWorkbook.Worksheets("TF")
Set OIL = ThisWorkbook.Worksheets("OIL")
Set WTR = ThisWorkbook.Worksheets("WTR")
Set TG = ThisWorkbook.Worksheets("TG")
Set GL = ThisWorkbook.Worksheets("GL")
Set RG = ThisWorkbook.Worksheets("RG")
Set WC = ThisWorkbook.Worksheets("RG")
Set MM = ThisWorkbook.Worksheets("Master Monitor")
Set VRRStart = ThisWorkbook.Worksheets("VRRStart")
Application.ScreenUpdating = False
ClrChts
Lastcol = TF.Cells(5, Columns.Count).End(xlToLeft).Column
For Currcol = 2 To Lastcol
Set cht = ThisWorkbook.Charts.Add
'VRRstart Plot
With cht.SeriesCollection.NewSeries
.Name = "=" & VRRStart.Name & "!R1C2"
.Values = "=" & VRRStart.Name & "!R" & 7 & "C" & Currcol & ":R" & 8 & "C" & Currcol
.XValues = "=" & VRRStart.Name & "!R" & 7 & "C1:R" & 8 & "C1"
.Border.Color = RGB(0, 0, 0)
.Format.Line.Weight = 3
End With
'OIL Plot
With cht.SeriesCollection.NewSeries
.Name = "=" & OIL.Name & "!R1C2"
.Values = "=" & OIL.Name & "!R" & 6 & "C" & Currcol & ":R" & 96 & "C" & Currcol
.XValues = "=" & OIL.Name & "!R" & 6 & "C1:R" & 96 & "C1"
.Border.Color = RGB(153, 204, 0)
End With
'WTR Plot
With cht.SeriesCollection.NewSeries
.AxisGroup = 2
.Name = "=" & WTR.Name & "!R1C2"
.Values = "=" & WTR.Name & "!R" & 6 & "C" & Currcol & ":R" & 96 & "C" & Currcol
.XValues = "=" & WTR.Name & "!R" & 6 & "C1:R" & 96 & "C1"
.Border.Color = RGB(0, 0, 0)
End With
'TG Plot
With cht.SeriesCollection.NewSeries
.AxisGroup = 2
.Name = "=" & TG.Name & "!R1C2"
.Values = "=" & TG.Name & "!R" & 6 & "C" & Currcol & ":R" & 96 & "C" & Currcol
.XValues = "=" & TG.Name & "!R" & 6 & "C1:R" & 96 & "C1"
.Border.Color = RGB(255, 0, 0)
End With
'WC Plot
With cht.SeriesCollection.NewSeries
.Name = "=" & WC.Name & "!R1C2"
.Values = "=" & WC.Name & "!R" & 6 & "C" & Currcol & ":R" & 96 & "C" & Currcol
.XValues = "=" & WC.Name & "!R" & 6 & "C1:R" & 96 & "C1"
.Border.Color = RGB(255, 153, 0)
End With
With cht
.ChartType = xlXYScatterLines
.Axes(xlCategory).TickLabels.NumberFormat = "m/d/yy"
.HasTitle = True
.ChartTitle.Text = TF.Cells(4, Currcol)
.ChartTitle.Font.Size = 10
.HasLegend = True
.Legend.Position = xlLegendPositionBottom
.Location Where:=xlLocationAsObject, Name:=MM.Name
End With
'.Axes(xlCategory).MinimumScaleIsAuto = False
'.Axes(xlCategory).MinimumScale = 42248
'.Axes(xlCategory).MaximumScaleIsAuto = False
'.Axes(xlCategory).MaximumScale = 42338
'.Axes(xlValue).MinimumScaleIsAuto = False
'.Axes(xlValue).MinimumScale = 0
'.Axes(xlValue).MaximumScaleIsAuto = False
'.Axes(xlValue).MaximumScale = 860
Next Currcol
Application.ScreenUpdating = True
End Sub
Other sub :
Sub ClrChts()
Dim wks As Worksheet
For Each wks In Worksheets
If wks.ChartObjects.Count > 0 Then
wks.ChartObjects.Delete
End If
Next wks
End Sub
Is it an issue of using charts or chartobject add function?