Posts by Kieran

'There is no built-in "compact" option in Excel like the one in Access.


'Have a look at this thread - you will find some code there to get rid of unused rows and columns: 50564
'This is the version I use (copied from somebody else and adapted a bit):


' Remove superfluous rows and columns in each worksheet of the active workbook
Sub CleanUp()
    Dim ar As Range, r As Long, c As Integer, tr As Long, tc As Integer
    Dim ws As Worksheet, ur As Range, sh As Shape
    Dim fc As Boolean, fd As Boolean, fs As Boolean


    If ActiveWorkbook Is Nothing Then Exit Sub
    On Error Resume Next
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        Application.StatusBar = "Checking " & ws.Name & ", be patient please..."
        fc = ws.ProtectContents
        fd = ws.ProtectDrawingObjects
        fs = ws.ProtectScenarios
        ws.Unprotect
        r = 0
        c = 0
        Set ur = Union(ws.UsedRange.SpecialCells(xlCellTypeConstants), _
            ws.UsedRange.SpecialCells(xlCellTypeFormulas))
        If Err = 1004 Then
            Err.Clear
            Set ur = ws.UsedRange.SpecialCells(xlCellTypeConstants)
        End If
        If Err = 1004 Then
            Err.Clear
            Set ur = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
        End If
        If Err = 0 Then
            For Each ar In ur.Areas
                tr = ar.Range("A1").Row + ar.Rows.Count - 1
                tc = ar.Range("A1").Column + ar.Columns.Count - 1
                If tc > c Then c = tc
                If tr > r Then r = tr
            Next
            For Each sh In ws.Shapes
                tr = sh.BottomRightCell.Row
                tc = sh.BottomRightCell.Column
                If tc > c Then c = tc
                If tr > r Then r = tr
            Next
            ws.Rows(r + 1 & ":" & ws.Rows.Count).Delete
            ws.Range(ws.Cells(1, c + 1), ws.Cells(1, 256)).EntireColumn.Delete
        Else
            Err.Clear
        End If
        ws.Protect DrawingObjects:=fd, Contents:=fc, Scenarios:=fs
    Next
    Set ar = Nothing
    Set ur = Nothing
    Set ws = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Superfluous rows and columns have been removed.", vbInformation
End Sub

' Remove unused custom number formats.
' Remark: only checks cells in worksheets.
' Doesn't check charts, so any formats used in charts but not in cells will be removed.
' Uses SendKeys, which can cause problems.


Sub DeleteFormats()
    Dim strOldFormat As String
    Dim strNewFormat As String
    Dim aCell As Range
    Dim sht As Worksheet
    Dim strFormats() As String
    Dim fFormatsUsed() As Boolean
    Dim i As Integer, j As Integer, k As Integer
    If ActiveWorkbook.Worksheets.Count = 0 Then
        MsgBox "The active workbook contains no worksheets.", vbInformation
        Exit Sub
    End If
    On Error GoTo Exit_Sub
    Application.Cursor = xlWait
    ReDim strFormats(1000)
    ReDim fFormatsUsed(1000)
    Set aCell = Range("A1")
    aCell.Select
    strOldFormat = aCell.NumberFormatLocal
    aCell.NumberFormat = "General"
    strFormats(0) = "General"
    strNewFormat = aCell.NumberFormatLocal
    i = 1
    Do
        ' Dialog box requires local format
        SendKeys "{TAB 3}{DOWN}{ENTER}"
        Application.Dialogs(xlDialogFormatNumber).Show strNewFormat
        strFormats(i) = aCell.NumberFormat
        strNewFormat = aCell.NumberFormatLocal
        i = i + 1
    Loop Until strFormats(i - 1) = strFormats(i - 2)
    aCell.NumberFormatLocal = strOldFormat
    ReDim Preserve strFormats(i - 2)
    ReDim Preserve fFormatsUsed(i - 2)
    For Each sht In ActiveWorkbook.Worksheets
        For Each aCell In sht.UsedRange
            For i = 0 To UBound(strFormats)
                If aCell.NumberFormat = strFormats(i) Then
                    fFormatsUsed(i) = True
                    Exit For
                End If
            Next i
        Next aCell
    Next sht
    ' Prevent error on built-in formats
    On Error Resume Next
    For i = 0 To UBound(strFormats)
        If Not fFormatsUsed(i) Then
            ' DeleteNumberFormat requires international format
            ActiveWorkbook.DeleteNumberFormat strFormats(i)
        End If
    Next i
Exit_Sub:
    Set aCell = Nothing
    Set sht = Nothing
    Erase strFormats
    Erase fFormatsUsed
    Application.Cursor = xlDefault
End Sub


'Warning: always save a backup of your worksheet before "cleaning" it!

Option Explicit




Private Sub Worksheet_Activate()
Dim pt As PivotTable


    For Each pt In ActiveSheet.PivotTables
        pt.RefreshTable
    Next
End Sub

Option Explicit


Sub SelectSheets()
    Dim ws As Worksheet
    Dim c As Chart
        Dim SheetsArray()
    Dim Counter As Integer
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name Like "DS*" Then
            ReDim Preserve SheetsArray(Counter)
            SheetsArray(Counter) = ws.Name
            Counter = Counter + 1
        End If
    Next ws
        For Each c In ActiveWorkbook.Charts
        If c.Name Like "DS*" Then  ' or any other name etc...
            ReDim Preserve SheetsArray(Counter)
            SheetsArray(Counter) = c.Name
            Counter = Counter + 1
        End If
    Next ws
    
    Sheets(SheetsArray()).Select
End Sub

Sub SelectSheets()
Dim ws As Worksheet
Dim SheetsArray()
Dim Counter As Integer
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name Like "DS*" Then
        ReDim Preserve SheetsArray(Counter)
        SheetsArray(Counter) = ws.Name
        Counter = Counter + 1
    End If
Next ws
   Sheets(SheetsArray()).Select
End Sub