The following code makes a list of sheets:
Sub Listofcontent()
Dim objSheet As Worksheet
Dim intRow As Integer
Dim strCol As Integer
Dim GCell As Range
SearchText = "Content"
Set GCell = Worksheets("Front page").Cells.Find(SearchText).Offset(2, 0)
GCell.End(xlDown).ClearContents
intRow = GCell.Row
strCol = GCell.Column
For Each objSheet In ActiveWorkbook.Sheets
ActiveWorkbook.Worksheets("Front page").Hyperlinks.Add Anchor:=ActiveWorkbook.Worksheets("Front page").Cells(intRow, strCol), Address:="", SubAddress:= _
"'" & objSheet.name & "'!A1", TextToDisplay:=objSheet.name
With ActiveWorkbook.Worksheets("0.0 Forside").Cells(intRow, strCol).Font
.name = "Calibri"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
intRow = intRow + 1
Next objSheet
End Sub
It works now. Thanks. However, I want it to run whenever a sheet is added, deleted, renamed, moved, copied. I added this to the workbook code pane:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.EnableEvents = False
Listofcontent
Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.EnableEvents = False
Listofcontent
Application.EnableEvents = True
End Sub
Change this
For Each objSheet In ActiveWorkbook.Sheets.Count
To
For Each objSheet In ActiveWorkbook.Sheets
Related
I have a problem. I am trying to get records from the data base to Excel and afterwards format the Excel file. If I implement the whole function then it will run fine on one occasion. But if I run it again it sometimes gives the runtime 91 error. I was going through the debugging and if I only have the first ApXl in the function the code will work fine with no issues. However, if I add more of the code to reformat the Excel sheet then it will eventually give me the run time 91 even though the variables are already declared. Below is part of my code with some of the formatting.
Public Function ExportToExcelEM(Numbcases, strObjectType As String, strObjectName As String, Optional strSheetName As String, Optional strFileName As String)
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim intCount As Integer
Const xlToRight As Long = -4161
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Const xlContinuous As Long = 1
Dim OBJ As Object
On Error GoTo ExportToExcel_Err
DoCmd.Hourglass True
Select Case strObjectType
Case "Table", "Query"
Set rst = CurrentDb.OpenRecordset(strObjectName, dbOpenDynaset, dbSeeChanges)
Case "Form"
Set rst = Forms(strObjectName).RecordsetClone
Case "Report"
Set rst = CurrentDb.OpenRecordset(Reports(strObjectName).RecordSource, dbOpenDynaset, dbSeeChanges)
End Select
If rst.RecordCount = 0 Then
MsgBox "No records to be exported.", vbInformation, GetDBTitle
DoCmd.Hourglass False
Else
On Error Resume Next
Set ApXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set ApXL = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo ExportToExcel_Err
Set xlWBk = ApXL.Workbooks.Add
ApXL.Visible = False
Set xlWSh = xlWBk.Worksheets("Sheet1")
If Len(strSheetName) > 0 Then
xlWSh.Name = Left(strSheetName, 31)
End If
xlWSh.Range("A1").Select
Do Until intCount = rst.Fields.Count
ApXL.ActiveCell = rst.Fields(intCount).Name
ApXL.ActiveCell.Offset(0, 1).Select
intCount = intCount + 1
Loop
rst.MoveFirst
xlWSh.Range("A2").CopyFromRecordset rst
** ** ** With ApXL
.Range("A1").Select
.Range(.Selection, .Selection.End(xlToRight)).Select
.Selection.Interior.Pattern = xlSolid
.Selection.Interior.PatternColorIndex = xlAutomatic
.Selection.Interior.TintAndShade = -0.25
.Selection.Interior.PatternTintAndShade = 0
.Selection.Borders.LineStyle = xlNone
.Selection.AutoFilter
.Cells.EntireColumn.AutoFit
.Cells.EntireRow.AutoFit
.Range("B2").Select
.ActiveWindow.FreezePanes = True
.ActiveSheet.Cells.Select
.ActiveSheet.Cells.WrapText = False
.ActiveSheet.Cells.EntireColumn.AutoFit
.Visible = False
End With********
With ApXL
xlWSh.Rows(1).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End With
xlWBk.SaveAs FileName:=strFileName, FileFormat:=51
xlWBk.Close
Set xlWBk = Nothing
Set xlWSh = Nothing
Set ApXL = Nothing
' end of doing anything with excel
End If
rst.Close
Set rst = Nothing
DoCmd.Hourglass False
ExportToExcel_Exit:
DoCmd.Hourglass False
Exit Function
ExportToExcel_Err:
DoCmd.SetWarnings True
Set xlWBk = Nothing
Set xlWSh = Nothing
Set ApXL = Nothing
rst.Close
MsgBox Err.Description, vbExclamation, Err.Number
DoCmd.Hourglass False
Resume ExportToExcel_Exit
End Function
debugging: works once after adding more formatting in my code but then gives me a runtime 91 error. I added more code chunks to the code till it was the complete excel function I desired. Throughout the process it would give me the finish piece I wanted but afterwards gives me a runtime error 91.
After running procedure, check if instance of Excel is still showing in Task Manager. This can be result of using Active______ referencing. Use explicit reference instead.
When I compile your procedure, I get "Method or data member not found." error on each line in the xlWSh.Rows(1).Select block. Use With .Rows(1) instead.
Could probably perform this process without actually selecting anything. Use explicit Cells or Range reference: With .Range("A1:E1") - construct reference with variables.
Modified your code to apply and it works:
intCount = rst.Fields.Count
Set xlWSh = xlWBk.worksheets("Sheet1")
With xlWSh
If strSheetName <> "" Then .Name = Left(strSheetName, 31)
For x = 1 To intCount
.Cells(1, x).Value = rst(x - 1).Name
Next
.Range("A2").CopyFromRecordset rst
With .Range(.Cells(1, 1), .Cells(1, intCount))
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.TintAndShade = -0.25
.Interior.PatternTintAndShade = 0
.Borders.LineStyle = xlNone
.AutoFilter
.EntireColumn.AutoFit
End With
With .Rows(1)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.shrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
.Rows.AutoFit
End With
ApXL.Windows(1).SplitColumn = 1
ApXL.Windows(1).SplitRow = 1
ApXL.Windows(1).FreezePanes = True
I am doing a document using a userform. In the userform I setup radiobuttons when clicked I want the text from a macro that I did to be inserted at a specific bookmark in my document. Help please
This is my macro:
Sub ordonnance()
'
' ORDONNANCE Macro
'
'
Dim bmSignet As Bookmark
Dim rgPlageDuSignet As Range
Set bmSignet = ActiveDocument.Bookmarks("ORDONNANCE_DE")
Set rgPlageDuSignet = bmSignet.Range
rgPlageDuSignet.Select
ActiveDocument.Tables.Add rgPlageDuSignet, 1, 1
With Selection.Tables(1)
If .Style <> "Grille du tableau" Then
.Style = "Grille du tableau"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="ORDONNANCE DE NON-PUBLICATION ..."
Set bmSignet = Nothing
Set rgPlageDuSignet = Nothing
End Sub
This is my radiobutton:
Private Sub OptionButton3_Click()
If Me.OptionButton3.Value = True Then
Call RemplaceSignet("ORDONNANCE_DE", "ORDONNANCE DE NON-PUBLICATION ...")
Else
Call RemplaceSignet("ORDONNANCE_DE", " ")
End If
End Sub
Try:
Sub ordonnance(StrBkMk As String, StrTxt As String)
'
' ORDONNANCE Macro
'
'
Dim Tbl As Table
With ActiveDocument
Set Tbl = .Tables.Add(.Bookmarks(StrBkMk).Range, 1, 1)
With Tbl
.Style = "Grille du tableau"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
With .Cell(1, 1).Range
With .Font
.Name = "Arial"
.Size = 12
.Bold = True
End With
.Text = StrTxt
End With
End With
End With
Set Tbl = Nothing
End Sub
Note that there is no need to select anything.
I have a macro ("List_of_sheets") that creates a list of all the sheets in the workbook, and places the list in the "Sheetlist"-sheet underneath the "Header"-word.
The macro deletes the previous list and creates a new list, whenever I run the macro. I do this manually whenever I delete, add, copy or change the name of sheet. However, I want this to run automatically.
Thanks in advance!
Sub List_of_sheets()
Dim objSheet As Worksheet
Dim intRow As Integer
Dim strCol As Integer
Dim GCell As Range
SearchText = "Header"
Set GCell = Worksheets("Listsheet").Cells.Find(SearchText).Offset(2, -1)
GCell.End(xlDown).ClearContents
intRow = GCell.Row
strCol = GCell.Column
For Each objSheet In ActiveWorkbook.Sheets
ActiveWorkbook.Worksheets("Listsheet").Hyperlinks.Add Anchor:=ActiveWorkbook.Worksheets("Listsheet").Cells(intRow, strCol), Address:="", SubAddress:= _
"'" & objSheet.Name & "'!A1", TextToDisplay:=objSheet.Name
With ActiveWorkbook.Worksheets("Listsheet").Cells(intRow, strCol).Font
.Name = "Calibri"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
intRow = intRow + 1
Next objSheet
End Sub
you have to go with Workbooks events, although they don't cover the case of a sheet name change
but as a workaround you could use Workbook_SheetActivate since when you change the name of a sheet and then you want to see if the list has been updated you have to activate the list sheet
so place in ThisWorkbook code pane the following:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.EnableEvents = False
List_of_sheets
Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.EnableEvents = False
List_of_sheets
Application.EnableEvents = True
End Sub
and you could consider the following refactoring of your code
Option Explicit
Sub List_of_sheets()
Dim objSheet As Worksheet
Dim intRow As Integer
Dim strCol As Integer
Dim GCell As Range
Dim SearchText As String
SearchText = "Header"
Set GCell = Worksheets("Listsheet").UsedRange.Find(what:=SearchText, lookat:=xlWhole, LookIn:=xlValues).Offset(2, -1)
GCell.End(xlDown).ClearContents
intRow = GCell.Row
strCol = GCell.Column
Dim listSheet As Worksheet
With ActiveWorkbook
Set listSheet = .Worksheets("Listsheet")
For Each objSheet In .Sheets
listSheet.Hyperlinks.Add Anchor:=listSheet.Cells(intRow, strCol), Address:="", SubAddress:= _
"'" & objSheet.Name & "'!A1", TextToDisplay:=objSheet.Name
intRow = intRow + 1
Next objSheet
End With
With listSheet.Cells(GCell.Row, strCol).Resize(Sheets.Count).Font
.Name = "Calibri"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
End Sub
I have written the below code to cycle through my worksheets as a kind of slideshow to use in a sales department. The code works perfectly when I step through in debug mode, however when I run the macro it only works intermittently, occasionally getting to the selecting of the worksheets without having reactivated the screen updating application function.
Here is the code I have created so far:
Sub Runshow()
Dim ws As Worksheet
On Error GoTo exit_
Application.EnableCancelKey = xlErrorHandler
For Each ws In ThisWorkbook.Worksheets
ws.Protect
Next
Application.DisplayFullScreen = True
Application.DisplayFormulaBar = False
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHorizontalScrollBar = False
ActiveWindow.DisplayVerticalScrollBar = False
Application.Calculation = xlManual
Let y = 0
Do Until y = 80
Application.ScreenUpdating = False
Workbooks.Open("c:\users\admin\downloads\crm.xlsx").Activate
Application.Calculate
ActiveWorkbook.Close savechanges = False
Application.ScreenUpdating = True
ThisWorkbook.Activate
Let x = 0
Do Until x = 23
For Each ws In ActiveWorkbook.Worksheets
ws.Select
Application.Wait (Now + TimeValue("00:00:10"))
x = x + 1
Next
Loop
y = y + 1
Loop
exit_:
For Each ws In ThisWorkbook.Worksheets
ws.Unprotect
Next
Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayGridlines = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
Application.Calculation = xlAutomatic
End Sub
I put together some simple code that does something similar, and works well. You can build out from here - ask any questions if there's anything you don't understand.
Sub Slideshow()
Dim ws As Worksheet
PrepareView True
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Application.Wait (Now + TimeValue("00:00:10"))
Next ws
PrepareView False
End Sub
Function PrepareView(status As Boolean)
If status = True Then
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHorizontalScrollBar = False
ActiveWindow.DisplayVerticalScrollBar = False
ElseIf status = False Then
Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayGridlines = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
End If
End Function
In SetWS sheet I have the following code in Worksheet_Deactivate:
Private Sub Worksheet_Deactivate()
Dim ActWS, SetWS As Worksheet
Set ActWS = ActiveWorkbook.Sheets("Activity_Plan")
Set SetWS = ActiveWorkbook.Sheets("Settings")
With ActWS.Range("J11:J20").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Settings!$AS$10:$AS$20" '
.IgnoreBlank = True
.InCellDropdown = True
End With '
End Sub
In RepWS sheet (where I only create a couple of graphs) I have the following code in Worksheet_Activate:
Private Sub Worksheet_Activate()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ScopeWS, RepWS, ActWS, SetWS As Worksheet
Set ScopeWS = ActiveWorkbook.Sheets("Scope")
Set RepWS = ActiveWorkbook.Sheets("Rep")
Set ActWS = ActiveWorkbook.Sheets("Activity_Plan")
Set SetWS = ActiveWorkbook.Sheets("Settings")
LRowScopeE = ScopeWS.Range("E" & Rows.Count).End(xlUp).Row
If SetWS.Range("W17") > SetWS.Range("W18") Then '
MsgBox ("bla bla")
Exit Sub
End If
RepWS.ChartObjects("Diagramm 3").Activate
ActiveChart.SeriesCollection(1).Name = "=Scope!$M$4"
ActiveChart.SeriesCollection(1).Values = "=Scope!$M$11:$M$" & LRowScopeE
ActiveChart.SeriesCollection(1).XValues = "=Scope!$E$11:$E$" & LRowScopeE
ActiveChart.SeriesCollection(2).Name = "=Scope!$P$4"
ActiveChart.SeriesCollection(2).Values = "=Scope!$P$11:$P$" & LRowScopeE
ActiveChart.SeriesCollection(3).Name = "=Scope!$U$4"
ActiveChart.SeriesCollection(3).Values = "=Scope!$T$11:$T$" & LRowScopeE
ActiveChart.Axes(xlValue).MaximumScaleIsAuto = True
ActiveChart.Axes(xlValue).TickLabels.NumberFormat = "#.##0 €"
ActiveChart.FullSeriesCollection(1).DataLabels.NumberFormat = "#.##0 €"
ActiveSheet.ChartObjects("Diagramm 14").Activate
ActiveChart.SeriesCollection(1).Name = "=Settings!$CJ$10"
ActiveChart.SeriesCollection(1).Values = "=Settings!$CJ$11:$CJ$" & SetWS.Range("CL8").Value
ActiveChart.SeriesCollection(1).XValues = "=Settings!$CI$11:$CI$" & SetWS.Range("CL8").Value
ActiveChart.SeriesCollection(2).Name = "=Settings!$CK$10"
ActiveChart.SeriesCollection(2).Values = "=Settings!$CK$11:$CK$" & SetWS.Range("CL8").Value
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
When I switch from SetWS to RepWS, it throws an error
"Application defined or object defined error"
and highlights in SetWS the following:
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Settings!$AS$10:$AS$20"
Switching between any other pair of sheets in this file does not cause this error (e.g. switching SetWS to any other sheet is OK).
UPDATE: I notice I more thing - As soon as I activate RepWS once, any further attempt to switch from SetWS to RepWS throws an error. Something is wrong with RepWS code...
Avoid the use of Active(Workbook/Sheet/Cell/Chart/...), the .Activate/.Select method and the .Selection property.
your worksheet_activate sub, might look something like this
Private Sub Worksheet_Activate()
Dim ScopeWS, RepWS, ActWS, SetWS As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With ThisWorkbook
Set ScopeWS = .Sheets("Scope")
Set RepWS = .Sheets("Rep")
Set ActWS = .Sheets("Activity_Plan")
Set SetWS = .Sheets("Settings")
End With
LRowScopeE = ScopeWS.Range("E" & Rows.Count).End(xlUp).Row
If SetWS.Range("W17") > SetWS.Range("W18") Then '
MsgBox ("bla bla")
Else
With RepWS
'Diagram 3
With .ChartObjects("Diagram 3").Chart
'Series 1
With .SeriesCollection(1)
.Name = "=Scope!$M$4"
.Values = "=Scope!$M$11:$M$" & LRowSco
.XValues = "=Scope!$E$11:$E$" & LRowScopeE
End With
'Series 2
With .SeriesCollection(2)
.Name = "=Scope!$P$4"
.Values = "=Scope!$P$11:$P$" & LRowScopeE
End With
'Series 3
With .seriescolection(3)
.Name = "=Scope!$U$4"
.Values = "=Scope!$T$11:$T$" & LRowScopeE
End With
'Layout
With .Axes(xlValue)
.MaximumScaleIsAuto = True
.TickLabels.NumberFormat = "#.##0 €"
End With
.FullSeriesCollection(1).DataLabels.NumberFormat = "#.##0 €"
End With
'Diagram 14
With .ChartObjects("Diagram 14").Chart
'Series 1
With .SeriesCollection(1)
.Name = "=Settings!$CJ$10"
.Values = "=Settings!$CJ$11:$CJ$" & SetWS.Range("CL8").Value
.XValues = "=Settings!$CI$11:$CI$" & SetWS.Range("CL8").Value
End With
'Series 2
With .SeriesCollection(2)
.Name = "=Settings!$CK$10"
.Values = "=Settings!$CK$11:$CK$" & SetWS.Range("CL8").Value
End With
End With
End With
End If
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub