OS and Software > Microsoft Help > [Excel] VBA question

[Excel] VBA question

Remove this: ActiveWindow.SelectedSheets.Delete

You could use some code like this.

For Each sh In Sheets
sh.Select
If sh.Name "Sheet1" Then 'your code goes here
Next sh

For Each sh In Sheets
sh.Select
If sh.Name "Sheet1" Then ActiveWindow.SelectedSheets.Delete
Next sh
--
He is no fool who gives up what he cannot keep, to gain what he cannot lose. - Jim Elliot

I got a reply from 2kmaro from a direct email. If he agrees, I will post the code.

OldAuditor

reply to OldAuditor
No problem, mine was just getting you in the right direction

reply to OldAuditor
Since some may want to see the code, here it is, hopefully well commented for your understanding. There is a very nice "Find last used row number, column number or cell address" function by Ron de Bruin, a fellow Microsoft Excel MVP, that I tossed into the mix. It can be used in other VBA projects where you may need to continually find the 'last' on a sheet.

The code:

Sub ConsolidateSheets()
  Dim srcWS As Worksheet
  Dim destWS As Worksheet
  Dim lastCellAddress As String
  Dim nextPasteRow As Long
  
  Set destWS = Worksheets("Sheet1") ' change name as needed
  'this is not required, but will help keep the screen from
  'flickering if you're on one of the sheets that's going to
  'be deleted
  destWS.Activate
  'this makes things go much faster by not updating the screen
  'while work is being done.
  'it will automatically be reset to = True when
  'the routine is finished.  So you won't see results until
  'after you click [OK] on the notice message at the end of it all.
  Application.ScreenUpdating = False
  'work through all the sheets in the workbook
  For Each srcWS In ThisWorkbook.Worksheets
    'but make sure we don't try to copy Sheet1's stuff back into itself
    If srcWS.Name <> destWS.Name Then
      If UCase(Trim(srcWS.Name)) <> "OVERVIEW" Then
        'this uses the nice routine from Ron de Bruin that is in here
        'to get the address of the lower-right-corner cell of the
        'actually used range on the sheet.
        '   ActiveCell.SpecialCells(xlLastCell)) is not always accurate
        '   it can set you up to copy empty rows.  Just as ActiveSheet.UsedRange
        '   can be inaccurate.
        lastCellAddress = rdbLast(3, srcWS.Cells)
        'get next available row based on used cells in column "A" on Sheet1
        'this looks from bottom of sheet upwards in the column until it
        'hits a non-empty cell (assumes last possible cell in that column is empty
        'to begin with).  We get that row number and add 1 to it to give us the
        'next presumed empty row on Sheet1
        nextPasteRow = destWS.Range("A" & Rows.Count).End(xlUp).Row + 1
        'this is a safety valve to make sure we don't start pasting
        'into Sheet1 until at least row 11.
        If nextPasteRow < 11 Then
          nextPasteRow = 11
        End If
        srcWS.Range("A1:" & lastCellAddress).Copy destWS.Range("A" & nextPasteRow)
        Application.CutCopyMode = False ' just for neat appearance
        'hide alerts from the user so you don't have to confirm the
        'delete of each of the worksheets.
        Application.DisplayAlerts = False
        srcWS.Delete
        Application.DisplayAlerts = True ' re-enable alerting
      Else
        'this is the "Overview" sheet, simply delete it
        Application.DisplayAlerts = False
        srcWS.Delete
        Application.DisplayAlerts = True ' re-enable alerting
      End If
    End If
  Next
  'this is good practice, though according to Microsoft it isn't needed
  Set srcWS = Nothing ' releases used resource back to the operating system
  Set destWS = Nothing ' which prevents "memory leaks" from continued reuse at one sitting
  MsgBox "Task Complete" ' announce job done to the user
End Sub
Function rdbLast(choice As Long, rng As Range)
'Ron de Bruin, 5 May 2008
'source page: http://www.rondebruin.nl/last.htm
' 1 = last row
' 2 = last column
' 3 = last cell
    Dim lrw As Long
    Dim lcol As Long
 
    Select Case choice
 
    Case 1:
        On Error Resume Next
        rdbLast = rng.Find(What:="*", _
                        After:=rng.Cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        On Error GoTo 0
 
    Case 2:
        On Error Resume Next
        rdbLast = rng.Find(What:="*", _
                        After:=rng.Cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0
 
    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       After:=rng.Cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0
 
        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        After:=rng.Cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0
 
        On Error Resume Next
        rdbLast = rng.Parent.Cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            rdbLast = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0
 
    End Select
End Function