Generating a macro button with a macro - excel

Using Excel 2013, I am looking to insert code into preexisting macro called "Rebuild_TOC" to generate a macro button on my "TOC" worksheet which calls "Repair_Back_To_TOC", a macro. I would like it to appear on my TOC at cells C2:E3, if possible, named "Rebuild Back to TOC Hyperlinks".
How would I go about accomplishing this with my current code?:
Sub Rebuild_TOC()
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Set wbBook = ActiveWorkbook
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
' If the TOC sheet already exist delete it and add a new worksheet.
On Error Resume Next
Application.EnableEvents = False
With wbBook
.Worksheets("TOC").Delete
.Worksheets.Add Before:=.Worksheets(1)
End With
Application.EnableEvents = True
On Error GoTo 0
Set wsActive = wbBook.ActiveSheet
With wsActive
.Name = "TOC"
With.Range("A1:B1")
.Value = Array("Table of Contents", "Sheet # – # of Pages")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
' Iterate through the worksheets in the workbook and create sheetnames, add hyperlink
' and count & write the running number of pages to be printed for each sheet on the TOC.
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
wsSheet.Activate
With wsActive
.Hyperlinks.Add .Cells(lnRow, 1), "", _
SubAddress:= wsSheet.Name & "!A1", _
TextToDisplay:=wsSheet.Name
lnPages = wsSheet.PageSetup.Pages().Count
.Cells(lnRow, 2).Value = "‘" & lnCount & "-" & lnPages
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
wsActive.Activate
wsActive.Columns("A:B").EntireColumn.AutoFit
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

Related

Optimize Excel VBA Macro for Copy-PasteValues

I'm new in Excel-VBA and I need to improve my macro performance. I have a macro that searches an excel, opens it, then goes through every sheet and copy-pastevalues for all cell with a specific color (yellow). Finally saves and closes the excel. In addition, excels sheets are locked and only those yellow cells are editable. This should be done for a list of excel that I indicate in a main template from where I call the macro. The problem is that it takes a lot of time and even gets blocked when the number of excels is more than 3.
I paste my code below and hope anyone can help. Thanks!
Sub Button1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim filePath As String
Dim rng As Range
Dim cel As Range
Dim cartera As String
Dim plantilla As String
Dim wb As Workbook
Dim ws As Worksheet
Dim obj_Cell As Range
filePath = Application.ThisWorkbook.Path
Range("B9").Select
Set rng = Application.Range(Selection, Selection.End(xlDown))
For Each cel In rng.Cells
cartera = cel.Value
plantilla = cel.Offset(0, 1).Value
If cartera = vbNullString Or plantilla = vbNullString Then
GoTo Saltar
End If
Application.StatusBar = "Ejecutando Cartera: " & cartera & ", Plantilla: " & plantilla
Set wb = Workbooks.Open(filePath & "\" & cartera & "\" & plantilla, UpdateLinks:=3)
For Each ws In wb.Worksheets
If ws.Name <> "Index" And ws.Name <> "Instructions" And ws.Name <> "Glossary" Then
Worksheets(ws.Name).Activate
For Each obj_Cell In Range("A1:DW105")
With obj_Cell
If obj_Cell.Interior.Color = RGB(255, 255, 153) Then
obj_Cell.Select
If obj_Cell.MergeCells = True Then
obj_Cell.MergeArea.Select
End If
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
If obj_Cell.MergeCells = True Then
If obj_Cell.MergeArea(1).Value = vbNullString Then
obj_Cell.MergeArea.Cells(1, 1).Select
Selection.ClearContents
End If
Else
If obj_Cell.Value = vbNullString Then
obj_Cell.ClearContents
End If
End If
End If
End With
Next obj_Cell
Range("A1").Select
End If
Next ws
Sheets(1).Select
wb.Close SaveChanges:=True
Saltar:
Next cel
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
End Sub
Untested- just some "start" ideas for you to use (e.g. no selections, using arrays, fix With statement, no GoTo). I don't understand the logic behind clearing vbNullstring. If it is necessary adapt the code in your way.
I would also suggest opening files with displayalerts on because of few potential problems (e.g. "serious error occur last time file was opened" would hangs your macro)
Sub Button1_Click()
With Application
.ScreenUpdating = False
.StatusBar = True
End With
' If possible change this reference
' from active sheet to sheet's name/codename/index
Dim activeWs As Worksheet
Set activeWs = ActiveSheet
Dim filePath As String
filePath = Application.ThisWorkbook.Path
Dim wb As Workbook
Dim ws As Worksheet
Dim obj_Cell As Range
' range definition
' if lastRow not working change to yours xlDown
' if possible End(xlUp) method is more reliable
Dim rng As Range
Dim lastRw As Long
With activeWs
lastRw = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
Set rng = .Range("B9:B" & lastRw)
End With
' read whole ranges at once
' instead of offset it is possible also to read
' cartera and plantilla at the same time to 2Darray
Dim cartera As Variant
cartera = Application.Transpose(rng.Value2)
Dim plantilla As Variant
plantilla = Application.Transpose(rng.Offset(, 1).Value2)
' main loop
Dim i As Long
For i = 1 To UBound(cartera)
If cartera(i) <> vbNullString Or plantilla(i) <> vbNullString Then
Application.StatusBar = "Ejecutando Cartera: " & cartera(i) & ", Plantilla: " & plantilla(i)
Set wb = Workbooks.Open(filePath & "\" & cartera(i) & "\" & plantilla(i), UpdateLinks:=3)
For Each ws In wb.Worksheets
If ws.Name <> "Index" And ws.Name <> "Instructions" And ws.Name <> "Glossary" Then
For Each obj_Cell In ws.Range("A1:DW105")
With obj_Cell
If .Interior.Color = RGB(255, 255, 153) Then
.Value2 = .Value2
' I commented this part beacuse it does not make sense for me...
' If .MergeCells Then
' If .MergeArea(1).Value = vbNullString Then _
.MergeArea.Cells(1, 1).ClearContents
' Else
' If .Value = vbNullString Then .ClearContents
' End If
End If
End With
Next obj_Cell
End If
Next ws
' I would place diplayalerts off here because of potential problems
' with opening files
' if problem occurs it can macro hangs
Application.DisplayAlerts = False
wb.Close SaveChanges:=True
Application.DisplayAlerts = True
End If
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = False
End With
End Sub

VBA copy a range based on values from 2 separate sheets

I do not know what I am doing wrong. The code will run but it does not copy the data as expected, all the values seem to be overwriting to row 1 on the target sheet (tsht) instead of copying data down the target sheet. The goal here is to take data and iterate it for every county listed on the group ID tab (captured by SubCell.Value). Where plan codes and term dates match, the macro should copy each matching row from dsht for the indicated number of counties on gsht to the tsht. Can anyone see my error or why this code is keeping data all in the top row of the tsht?
Sub GroupID_Breakout()
Dim dsht As Worksheet 'data sheet target
Dim gsht As Worksheet
Dim tsht As Worksheet
Dim dlrow As Long
Dim glrow As Long
Dim tlrow As Long
Dim SubCell As Range
Dim rngCell As Range
Dim Result() As String
Dim countycount As Long
Set dsht = ThisWorkbook.Worksheets("Data_No Formulas")
Set gsht = ThisWorkbook.Worksheets("GroupID")
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete compare tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Data_Final").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Data_No Formulas")).Name = "Data_Final" 'create new tab
Set tsht = ThisWorkbook.Worksheets("Data_Final")
With dsht.Range("A2:CN2")
tsht.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
glrow = gsht.Cells(Rows.Count, 1).End(xlUp).Row
dlrow = dsht.Cells(Rows.Count, 1).End(xlUp).Row
For Each SubCell In gsht.Range("I2:I" & glrow)
countycount = SubCell.Value
Result() = Split(SubCell.Offset(0, -2).Value, ",")
For Each rngCell In dsht.Range("A3:A" & dlrow)
a = 0
If SubCell.Offset(0, -4).Value = rngCell.Value And SubCell.Offset(0, -8).Value = rngCell.Offset(0, 5).Value Then
For i = 1 To countycount
tlrow = tsht.Cells(Rows.Count, 1).End(xlUp).Row
With dsht.Range(rngCell, rngCell.Offset(0, 91))
tsht.Range("A" & tlrow).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
tsht.Range("L" & tlrow).Value = Result(a)
i = i + 1
Next
a = a + 1
End If
Next rngCell
Next SubCell
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Macro Complete!")
Exit Sub
Errhandler:
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Select Case Err.Number
'different error handling here
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Summary"
End Select
End Sub
This has been resolved with the below code, I wanted to post the resolution in case anyone finds a way to make this code work for them. Sorry I couldn't get this to copy over as clean as my 1st block.
Solution:
Sub GroupID_Breakout()
Dim dsht As Worksheet 'data sheet target
Dim gsht As Worksheet
Dim tsht As Worksheet
Dim dlrow As Long
Dim glrow As Long
Dim tlrow As Long
Dim SubCell As Range
Dim rngCell As Range
Dim Result() As String
Dim countycount As Long
Set dsht = ThisWorkbook.Worksheets("Data_No Formulas")
Set gsht = ThisWorkbook.Worksheets("GroupID")
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete compare tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Data_Final").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Data_No Formulas")).Name = "Data_Final" 'create new tab
Set tsht = ThisWorkbook.Worksheets("Data_Final")
'pull header from dsht to tsht
With dsht.Range("A2:CN2")
tsht.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
glrow = gsht.Cells(Rows.Count, 1).End(xlUp).Row
dlrow = dsht.Cells(Rows.Count, 1).End(xlUp).Row
For Each SubCell In gsht.Range("I2:I" & glrow)
countycount = SubCell.Value
Result() = Split(SubCell.Offset(0, -2).Value, ",") 'separates a list of counties by comma to reference as "Result(0)"
For Each rngCell In dsht.Range("A3:A" & dlrow)
a = 0
i = 1
For i = 1 To countycount
If SubCell.Offset(0, -4).Value = rngCell.Value And SubCell.Offset(0, -8).Value = rngCell.Offset(0, 5).Value Then 'match dates and plan codes
'move row where match is found between dsht and gsht variables
With dsht.Range(rngCell, rngCell.Offset(0, 91))
tlrow = tsht.Cells(Rows.Count, 1).End(xlUp).Row
tsht.Range("A" & (tlrow + 1)).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
'place county names captured by split above with each iteration
tsht.Range("L" & (tlrow + 1)).Value = Result(a)
End If
a = a + 1
Next i
Next rngCell
Next SubCell
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Macro Complete!")
Exit Sub
Errhandler:
'bring back clunky processes
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Select Case Err.Number
'different error handling here
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Summary"
End Select
End Sub
tsht.Range("A" & tlrow).Resize(.Rows.Count, .Columns.Count).Value =
should be
tsht.Range("A" & (tlrow+1)).Resize(.Rows.Count, .Columns.Count).Value =

Excel TOC using vba - removed leading zeros

I used vba to create a TOC for my workbook, but the code formatted my wsname to a number format and removed the leading zeros. Is there a way to modify the code to include the leading zeros in the links?
For example, each of my worksheets is titled with a number beginning with a zero such as "0303855" etc. When I ran this code, my TOC list was numbers without the zero ("303855" etc).
I used the following code:
Sub CreateTOC()
Dim wsA As Worksheet
Dim ws As Worksheet
Dim wsTOC As Worksheet
Dim lRow As Long
Dim rngList As Range
Dim lCalc As Long
Dim strTOC As String
Dim strCell As String
lCalc = Application.Calculation
On Error GoTo errHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
strTOC = "TOC"
strCell = "A1"
Set wsA = ActiveSheet
On Error Resume Next
Set wsTOC = Sheets(strTOC)
On Error GoTo errHandler
If wsTOC Is Nothing Then
Set wsTOC = Sheets.Add(Before:=Sheets(1))
wsTOC.Name = strTOC
Else
wsTOC.Cells.Clear
End If
With wsTOC
.Range("B1").Value = "Sheet Name"
lRow = 2
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible _
And ws.Name <> strTOC Then
.Cells(lRow, 2).Value = ws.Name
.Hyperlinks.Add _
Anchor:=.Cells(lRow, 2), _
Address:="", _
SubAddress:="'" & ws.Name _
& "'!" & strCell, _
ScreenTip:=ws.Name, _
TextToDisplay:=ws.Name
lRow = lRow + 1
End If
Next ws
Set rngList = .Cells(1, 2).CurrentRegion
rngList.EntireColumn.AutoFit
.Rows(1).Font.Bold = True
End With
Application.ScreenUpdating = True
wsTOC.Activate
wsTOC.Cells(1, 2).Activate
exitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = lCalc
Set rngList = Nothing
Set wsTOC = Nothing
Set ws = Nothing
Set wsA = Nothing
Exit Sub
errHandler:
MsgBox "Could not create list"
Resume exitHandler
End Sub

Excel VBA - open a workbook and pasting data

I found this excellent code however I need to adapt it for my purposes.
Firstly I need to open a data workbook that is on our network. The problem I have is that it is likely at times to be open by another user and will offer the option of "read only". How can I get it to accept the read-only option so that I can commence extracting the data.
Secondly it copies using the "=" . How can I change it to copy just the values?
First macro:
Sub test()
'to open another workbook
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\Schedule.xls"
ThisWorkbook.Activate
Application.ScreenUpdating = True
End Sub
2nd Macro:
Dim Sh As Worksheet
Dim Newsh As Worksheet
Dim myCell As Range
Dim ColNum As Integer
Dim RwNum As Long
Dim Basebook As Workbook
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Delete the sheet "Summary-Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Worksheets("Summary-Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Summary-Sheet"
Set Basebook = ThisWorkbook
Set Newsh = Basebook.Worksheets.Add
Newsh.Name = "Summary-Sheet"
'The links to the first sheet will start in row 2
RwNum = 1
For Each Sh In Basebook.Worksheets
If Sh.Name <> Newsh.Name And Sh.Visible Then
ColNum = 1
RwNum = RwNum + 1
'Copy the sheet name in the A column
Newsh.Cells(RwNum, 1).Value = Sh.Name
For Each myCell In Sh.Range("A1,D5:E5,Z10") '<--Change the range
ColNum = ColNum + 1
Newsh.Cells(RwNum, ColNum).Formula = _
"='" & Sh.Name & "'!" & myCell.Address(False, False)
Next myCell
End If
Next Sh
Newsh.UsedRange.Columns.AutoFit
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
You could always open the workbook as read-only if you are only extracting data.
Instead of using .formula use .value

Excel macro infinite loop keeps asking for user's input and can't "step into" to debug

I am creating a few macros to do the following in Excel 2010:
1. Upon creating a new worksheet ask for what the user wants to name his/her worksheet and sets the new worksheet to the name provided; calls Sort_Active_Book and Rebuild_TOC in order
2. Sort_Active_Book: Asks the user if he/she wants to sort the workbook's worksheets in ascending/descending order and proceeds to do so.
3. Rebuild_TOC: Deletes the Table of Contents page and rebuilds it based on all the worksheets in the workbook minus the TOC itself.
My problem is Excel keeps asking me to input the name of the new worksheet to be created and does not progress any further in the code. I notice it manages to create the named worksheet and asks me if I would like to sort ascending or descending but then proceeds to ask me again the name of the new worksheet. Could anyone please point out how to fix this and provide a code fix (if possible) please?
What I have already
This code portion is from ThisWorkbook, this is what prompts the user for the name of the worksheet upon creation.
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim sName As String
Dim bValidName As Boolean
Dim i As Long
bValidName = False
Do While bValidName = False
sName = InputBox("Please name this new worksheet:", "New Sheet Name", Sh.Name)
If Len(sName) > 0 Then
For i = 1 To 7
sName = Replace(sName, Mid(":\/?*[]", i, 1), " ")
Next i
sName = Trim(Left(WorksheetFunction.Trim(sName), 31))
If Not Evaluate("ISREF('" & sName & "'!A1)") Then bValidName = True
End If
Loop
Sh.Name = sName
Call Sort_Active_Book
Call Rebuild_TOC
End Sub
These two macros are in "Module 1":
Sub Sort_Active_Book()
Dim TotalSheets As Integer
Dim p As Integer
Dim iAnswer As VbMsgBoxResult
' Move the TOC to the begining of the document.
Sheets("TOC").Move Before:=Sheets(1)
' Prompt the user as to which direction they wish to
' sort the worksheets.
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) & "Clicking No will sort in Descending Order", vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For TotalSheets = 1 To Sheets.Count
For p = 2 To Sheets.Count - 1
' If the answer is Yes, then sort in ascending order.
If iAnswer = vbYes Then
If UCase$(Sheets(p).Name) = "TOC" Then
Sheets(p).Move Before:=Sheets(1)
ElseIf UCase$(Sheets(p).Name) > UCase$(Sheets(p + 1).Name) Then
Sheets(p).Move After:=Sheets(p + 1)
End If
' If the answer is No, then sort in descending order.
ElseIf iAnswer = vbNo Then
If UCase$(Sheets(p).Name) = "TOC" Then
Sheets(p).Move Before:=Sheets(1)
ElseIf UCase$(Sheets(p).Name) < UCase$(Sheets(p + 1).Name) Then
Sheets(p).Move After:=Sheets(p + 1)
End If
End If
Next p
Next TotalSheets
End Sub
and
Sub Rebuild_TOC()
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Set wbBook = ActiveWorkbook
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
' If the TOC sheet already exist delete it and add a new worksheet.
On Error Resume Next
With wbBook
.Worksheets(“TOC”).Delete
.Worksheets.Add Before:=.Worksheets(1)
End With
On Error GoTo 0
Set wsActive = wbBook.ActiveSheet
With wsActive
.Name = “TOC”
With .Range(“A1:B1”)
.Value = VBA.Array(“Table of Contents”, “Sheet # – # of Pages”)
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
' Iterate through the worksheets in the workbook and create sheetnames, add hyperlink
' and count & write the running number of pages to be printed for each sheet on the TOC.
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
wsSheet.Activate
With wsActive
.Hyperlinks.Add .Cells(lnRow, 1), “”, _
SubAddress:=”‘” & wsSheet.Name & “‘!A1”, _
TextToDisplay:=wsSheet.Name
lnPages = wsSheet.PageSetup.Pages().Count
.Cells(lnRow, 2).Value = “‘” & lnCount & “-” & lnPages
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
wsActive.Activate
wsActive.Columns(“A:B”).EntireColumn.AutoFit
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
You are creating a new sheet with sub Rebuild_TOC. Causing the newsheet macro to run again.
You will need to avoid running the newsheet macro by adding a enableevents = false and true surrounding your code when creating a new sheet for your TOC. The rest of your code appears to be working as you want it to.
Application.EnableEvents = False
With wbBook
.Worksheets("TOC").Delete
.Worksheets.Add Before:=.Worksheets(1)
End With
Application.EnableEvents = True
Why would you want to delete the TOC worksheet, why not just update it?

Resources