dslreports logo
site
 
    All Forums Hot Topics Gallery
spc

spacer




how-to block ads


Search Topic:
uniqs
850
share rss forum feed

OldAuditor

join:2007-03-24
Oklahoma City, OK

[Excel] VBA question

I use a program called OmniPage, which converts various formats to, in this case, Excel 2010. The only real problem is that it puts each sheet of the document in a separate sheet of the workbook. Obviously, consolidating a 100 page workbook into one sheet is very time-consuming.

I tried to automate it through a macro:

Sub Macro1()
'
' Macro1 Macro
' To consolidate sheets from Omnipage
'
Sheets("Sheet2").Select
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A10").Select
Selection.End(xlDown).Select
Range("A56").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.Delete
End Sub

This works fine for the second sheet.

The problem is that it references “Sheet2”. Once the sheet-delete code runs, the reference becomes invalid.

I’m sure this can be done through incrementing a variable, but I don’t know how to do it.

Any help would be appreciated.

TIA

Old



H2OuUp2
Happy to be here
Premium
join:2002-03-15
Oklahoma City, OK

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


OldAuditor

join:2007-03-24
Oklahoma City, OK

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

OldAuditor



H2OuUp2
Happy to be here
Premium
join:2002-03-15
Oklahoma City, OK
reply to OldAuditor

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



2kmaro
Think
Premium,ExMod 1 BC
join:2000-07-11
ColossalCave
kudos:1

1 edit
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