Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Please Improve My Slow Code, Excel 2010 VBA

Status
Not open for further replies.
ceddins

ceddins

Technical User
Jan 25, 2011
44
US
Good morning, everyone.

I apologize in advance for the large amount of code, but thank you for taking the time to look through it.

I have a worksheet before double click event set up on a tab called 'BNAGO.' When the user double clicks a Target cell containing a Convention Group name, a new tab is created that shows more information about that Group. A new tab can be created for as many times as there are groups in the Target range. When the new tab is created, I also set some Page Setup properties (this is probably where the slowest part it) so that the workbook is print-ready whenever the users exports the workbook to a PDF. Due to a bug in Excel, i can't set printcommunication to false when I set the header/footer, so that's why they are separated out. The code runs very slowly and I've already had coworkers comment on it.

Please help!

Code: 
Option Explicit
Option Base 1

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' This sub allows the user to double click a group name and see additional information about that
' group on another tab.
Dim NewTab As Worksheet
Dim DataRange As Range
Dim IndexArray
Dim i As Long
Dim x As Long
Dim y
Dim RebuildName As String
Dim Sheet As Worksheet
Dim RowVar As Long
Dim FindData
Application.ScreenUpdating = False

Dim ShtNm As Worksheet
Dim ShtCount As Long
ShtCount = 0

'check to see if the 4 main sheets exist. If not, then exit the sub. This section prevents the code from firing if saved in a new workbook
For Each ShtNm In Worksheets
    If ShtNm.Name = "DATA" Or ShtNm.Name = "Version Info" Or ShtNm.Name = "Filter" Or ShtNm.Name = "BNAGO" Then
        ShtCount = ShtCount + 1
    End If
Next
If ShtCount <> 4 Then
    Exit Sub
End If

'unprotect the workbook and sheets
ThisWorkbook.Unprotect ("stars")
Sheets("BNAGO").Unprotect ("stars")
Sheets("Version Info").Unprotect ("stars")
Sheets("Data").Unprotect ("stars")
Sheets("filter").Unprotect ("stars")

Set NewTab = Nothing

'take the cell that was double clicked and if there's not already a sheet with that name
'create a new 'drill-down' sheet and format it
    If (Target.Column = 4) And (Target.Row < 42 And Target.Row > 12) And (Target <> "") Then
'remove invalid characters from sheet name
        For x = 1 To Len(Target)
            y = Mid(Target, x, 1)
            If y Like "]" Or y Like "[[]" Or y Like "[*]" Or y Like "/" Or y Like "\" Or y Like "[?]" Or y Like "!" Or y Like "[#]" Then
                RebuildName = RebuildName + "_"
            Else
                RebuildName = RebuildName + y
            End If
        Next
        For Each Sheet In Worksheets
            If InStr(RebuildName, Sheet.Name) Then
            Sheet.Activate
            Cancel = True
            Exit Sub
            End If
        Next
        Set NewTab = Worksheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count - 2))

'rename sheet
        If Len(Target) > 31 Then
            NewTab.Name = Left(RebuildName, 31)
        Else
            NewTab.Name = RebuildName
        End If
        Cancel = True
    
'create array of values from 'DATA' tab that correspond to the target group and insert this in the 'drill-down' sheet
    NewTab.Range("A1").Value = Target.Value
    NewTab.Range("A2:A40") = Application.WorksheetFunction.Transpose(ThisWorkbook.Sheets("DATA").Range("A1:AM1"))
    ReDim IndexArray(1 To 39, 1)
    RowVar = Application.WorksheetFunction.Match(NewTab.Range("A1").Value, Sheets("DATA").Range("YrMthBookingPostAsCol"), 0) + 1
    For i = 1 To 39
        IndexArray(i, 1) = Sheets("DATA").Cells(RowVar, i)
    Next
    NewTab.Range("B2:B40") = IndexArray
    
    NewTab.Columns("A:A").ColumnWidth = 24.57
    NewTab.Columns("B:B").EntireColumn.AutoFit
    With NewTab.Range("B1:B41")
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    NewTab.Range("A41").Select
    NewTab.Activate
    
'page setup settings
    Application.PrintCommunication = False
    With NewTab.PageSetup
        .LeftMargin = Application.InchesToPoints(0.7)
        .RightMargin = Application.InchesToPoints(0.7)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintSheetEnd
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    With NewTab.PageSetup
        .LeftHeader = ""
        .RightHeader = ""
        .CenterHeader = "&9&F"
        .LeftFooter = "&9Printed on &D at &T"
        .CenterFooter = "&9&P of &N"
        .RightFooter = "&9Created by Gaylord Opryland Revenue Management"
    End With
    
    End If

'protect the workbook and sheets
ThisWorkbook.Protect ("stars")
Sheets("BNAGO").Protect ("stars")
Sheets("Version Info").Protect ("stars")
Sheets("Data").Protect ("stars")
Sheets("filter").Protect ("stars")

Application.ScreenUpdating = True
End Sub
 
Sort by date Sort by votes
A colleague was able to help me find a way around the problem. Instead of creating a new drill-down sheet and formatting it through page-setup every time a Target cell is double clicked, there's a 'Template' sheet that is already formatted that gets copied and renamed. This is much quicker than before. Here's the code in case someone out there has a similar issue.

Code: 
Option Explicit
Option Base 1

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' This sub allows the user to double click a group name and see additional information about that
' group on another tab.
Dim NewTab As Worksheet
Dim DataSheet As Worksheet
Dim DataRange As Range
Dim IndexArray
Dim i As Long
Dim x As Long
Dim y
Dim RebuildName As String
Dim Sheet As Worksheet
Dim RowVar As Long
Dim FindData
Application.ScreenUpdating = False

Dim ShtNm As Worksheet
Dim ShtCount As Long
ShtCount = 0

'check to see if the 4 main sheets exist. If not, then exit the sub. This section prevents the code from firing if saved in a new workbook
For Each ShtNm In Worksheets
    If ShtNm.Name = "DATA" Or ShtNm.Name = "Version Info" Or ShtNm.Name = "Filter" Or ShtNm.Name = "BNAGO" Then
        ShtCount = ShtCount + 1
    End If
Next
If ShtCount <> 4 Then
    Exit Sub
End If

'unprotect the workbook and sheets
ThisWorkbook.Unprotect ("stars")
Sheets("BNAGO").Unprotect ("stars")
Sheets("Version Info").Unprotect ("stars")
DataSheet.Unprotect ("stars")
Sheets("filter").Unprotect ("stars")
Sheets("Template").Unprotect ("stars")

Set DataSheet = ThisWorkbook.Sheets("DATA")
Set NewTab = Nothing

'take the cell that was double clicked and if there's not already a sheet with that name
'create a new 'drill-down' sheet and format it
    If (Target.Column = 4) And (Target.Row < 42 And Target.Row > 12) And (Target <> "") Then
'remove invalid characters from sheet name
        For x = 1 To Len(Target)
            y = Mid(Target, x, 1)
            If y Like "]" Or y Like "[[]" Or y Like "[*]" Or y Like "/" Or y Like "\" Or y Like "[?]" Or y Like "!" Or y Like "[#]" Then
                RebuildName = RebuildName + "_"
            Else
                RebuildName = RebuildName + y
            End If
        Next
        For Each Sheet In Worksheets
            If InStr(RebuildName, Sheet.Name) Then
            Sheet.Activate
            Cancel = True
            Exit Sub
            End If
        Next
        
        With ActiveWorkbook
            .Sheets("Template").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count - 3)
            Set NewTab = .Sheets("Template (2)")
        End With
        NewTab.Visible = True

'rename sheet
        If Len(Target) > 31 Then
            NewTab.Name = Left(RebuildName, 31)
        Else
            NewTab.Name = RebuildName
        End If
        Cancel = True
    
'create array of values from 'DATA' tab that correspond to the target group and insert this in the 'drill-down' sheet
    NewTab.Range("A1").Value = Target.Value
    NewTab.Range("A2:A40") = Application.WorksheetFunction.Transpose(DataSheet.Range("A1:AM1"))
    ReDim IndexArray(1 To 39, 1)
    RowVar = Application.WorksheetFunction.Match(NewTab.Range("A1").Value, DataSheet.Range("YrMthBookingPostAsCol"), 0) + 1
    For i = 1 To 39
        IndexArray(i, 1) = DataSheet.Cells(RowVar, i)
    Next
    NewTab.Range("B2:B40") = IndexArray
    
    NewTab.Columns("B:B").EntireColumn.AutoFit
    NewTab.Activate
    End If

'protect the workbook and sheets
ThisWorkbook.Protect ("stars")
Sheets("BNAGO").Protect ("stars")
Sheets("Version Info").Protect ("stars")
DataSheet.Protect ("stars")
Sheets("Filter").Protect ("stars")
Sheets("Template").Protect ("stars")

Application.ScreenUpdating = True
End Sub
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

remeng
  • Locked
  • Question
Run PowerShell Commands from Excel VBA
Replies
14
Views
1K
dhookom
dhookom
thanhthanh12
  • Locked
  • Question
Help vba
Replies
3
Views
319
combo
combo
Andrzejek
  • Locked
  • Question
Outlook VBA - Trust access
Replies
3
Views
449
hermanlaksko
hermanlaksko
SLW89
  • Locked
  • Question
VBA newbie needs help
Replies
4
Views
281
Andrzejek
Andrzejek
remeng
  • Locked
  • Question
Excel VBA to Pass Var between file macros after var changes
Replies
13
Views
297
mikrom
mikrom

Part and Inventory Search

Sponsor

Back
Top