VB problem - obsolete command/wider issues

[cheekbones3]

Hi all,

I'm currently trying to update a macro that was written in an earlier version of Excel, and I'm getting an error that I'm not sure what to do with.

The module that's getting called early in the program starts like this following (excluding Dim statements):

  For iCount = 0 To 10
    Workbooks(MacroWorkbookName).Worksheets("OpenBookList").Cells(4 + iCount, 2).Value = ""
  Next iCount
  iCount = 0
  For Each bk In Workbooks
    Workbooks(MacroWorkbookName).Worksheets("OpenBookList").Cells(4 + iCount, 2).Value = bk.Name
    iCount = iCount + 1
  Next bk

I can see that it seems to be making a list of the worksheet names. I'm not sure why it's doing this (maybe they're called later), but anyway, my problem is the "Subscript Out Of Range" error for the Worksheets("OpenBookList") part - OpenBookList is not defined as a variable.

I'm wondering:

1) Is this a reference that worked in a previous version of VB/Excel, but is now obsolete and simply acts as a variable?
2) If so, is there a new command I can insert here?
3) The macro sits in my Personal.xls workbook, but is supposed to work on whatever workbook is active when called. I'm wondering if I've made a mistake in how I called the macro?

More fundamentally, I think this program may need a wider overhaul, and if this particular question has no solution, would someone fancy having a look at the overall code to point out what needs to be done? I suspect there isn't much that needs fixed!

Thanks,
Ian

 

[VoG]

If you are getting a subscript out of range error it probably means that there isn't a sheet called OpenBookList in the workbook Workbooks(MacroWorkbookName)

 

[cheekbones3]

If you are getting a subscript out of range error it probably means that there isn't a sheet called OpenBookList in the workbook Workbooks(MacroWorkbookName)

That's painfully obvious to me now!

I'm just confused generally about why there's a specific reference to a worksheet now. Maybe I'm misunderstanding this macro. I wonder if it's supposed to be calling the worksheet where the dialogue box is found, which then refers to the active worksheet. Am I also misunderstanding how personal.xls works?

 

[VoG]

I think you'll need to post all of the code. But before you do, check whether there are any references to ThisWorkbook. If there are then try changing them all to ActiveWorkbook.

 

[cheekbones3]

Okay, here's the full whack, most of the modules are pretty self-explanatory I reckon.

Any advice welcome!

'   Re-Write of the Jammer 'Data Extractor' Macro;   October 1997
'   Redesign aims to get the parameters on a single input screen
'   Rather than a set of dialogues
'   Macro now checks the destination range. If it is not empty it returns
'   To the Parameter Screen
'   Macro copies values (and formats if selected) from specified range from
'   successive sheets into a vertical table on a single sheet in
'   a specified workbook.

' ***********************************
' First declare global variables
' ***********************************
Dim MacroWorkbookName As String


Dim SourceBook As Object
Dim DestBook As Object
Dim SourceSheet As Worksheet
Dim DestSheet As Worksheet
Dim DestSheetText As String
Dim SourceRange As Range
Dim SourceRangeText As String
Dim DestRange As Range
Dim DestRangeText As String
Dim OpenBooksCount As Integer
Dim SourceBookSheetsCount As Integer
Dim DestBookSheetsCount As Integer
Dim StartPageIndex As Integer
Dim EndPageIndex As Integer
Dim ToPageIndex As Integer
Dim SourceBookName As String
Dim DestBookName As String
Dim AddNamesFlag As Boolean
Dim AddCellRefFlag As Boolean
Dim PasteFormatsFlag As Boolean
Dim SpaceBetweenLines As Integer

Dim ExtractValues(100) As Variant
Dim ThisPageName As String
Dim NumberOfItems As Integer

Dim CancelFlag As Boolean



Sub FormattedExtraction()
  Dim DoExtract As Boolean
  Dim GotParams As Boolean

 
'   First, ask User to specify book, sheets and area to be copied,
'   book, sheet and starting point for table, and gap between table entries.
'
'   NB: The gap is the number of lines between the last row of the copied
'   area and the first row of the next area.
'

'   Introductory message and an option to quit
    CancelFlag = False
    startup = MsgBox("This macro will copy selected cells from successive sheets in " & _
        "a workbook into a vertical table in another workbook.  " & _
        "Please note: only values & formats can be copied.", 65, _
        "Formatted Data Extraction")
    If startup = vbCancel Then CancelFlag = True


'   Now get the neccessary information from the dialogue sheet
'
    If Not (CancelFlag) Then
       MacroWorkbookName = ActiveWorkbook.Name
       InitialiseDialogue
       If OpenBooksCount < 2 Then
          Response = MsgBox(" Can't run the Macro with only tme Macro workbook open ")
          CancelFlag = True
       End If
    End If
    
    If Not (CancelFlag) Then
       GotParams = False
       While (Not (GotParams) And Not (CancelFlag))
          Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue").Show
          If CancelFlag = False Then GotParams = CheckParameters
       Wend
    End If
    
    If Not (CancelFlag) Then
       DoTheExtraction
    End If
 End Sub
    
'
' The Extraction MACRO
'
'
        
Sub DoTheExtraction()
  Dim Row_offset, Col_offset As Integer
  Dim iCount, StepLength As Integer
  Dim ThisSheetIndex As Integer
  Dim ThisSheet As Worksheet
  Dim Rng As Variant
  Dim RangeFormats(100) As Variant

'   Now, using the User's specification of source and destination workbooks
'   the range of sheets from which data is to be extracted from the source workbook
'   the page into which the extracted data is to be copied top LHS of destination range  of table. Paste the
'   do the copying
    
' This copes with the possibility that the source pages have been specified backwards
    StepLength = 1
    If StartPageIndex > EndPageIndex Then StepLength = -1
    
' This is the extraction and copy loop which does the actual work

   
    Row_offset = 1
    ' This is the number of cells below the top RHS for writing the extracted values
    
    ' If Show Cell References has been checked, first write a row of cell references
    ' To do this we must convert Source Range Text into a sequence of cell references
    If AddCellRefFlag Then
      Set ThisSheet = Application.Workbooks(SourceBookName).Sheets(StartPageIndex)
      ThisPageName = ThisSheet.Name
      Set SourceRange = ThisSheet.Range(SourceRangeText)
    
      With Application.Workbooks(DestBookName).Sheets(ToPageIndex)
        Col_offset = 1
        If AddNamesFlag Then
           .Range(DestRangeText).Cells(Row_offset, Col_offset).Value = SourceBookName
           Col_offset = Col_offset + 1
        End If
        For Each Rng In SourceRange
          TmpString = ColumnLetter(Rng.Column)
          TmpString = TmpString + ","
          TmpString = TmpString + Str(Rng.Row)
          .Range(DestRangeText).Cells(Row_offset, Col_offset).Value = TmpString
          Col_offset = Col_offset + 1
        Next Rng
        Row_offset = Row_offset + 1
      End With
    End If

    For ThisSheetIndex = StartPageIndex To EndPageIndex Step StepLength
      Set ThisSheet = Application.Workbooks(SourceBookName).Sheets(ThisSheetIndex)
      ThisPageName = ThisSheet.Name
      Set SourceRange = ThisSheet.Range(SourceRangeText)
 
        ' Read in the values from the selected cells in the current sheet
        iCount = 0
        For Each Rng In SourceRange
          ExtractValues(iCount) = Rng.Value
          RangeFormats(iCount) = Rng.NumberFormat
          iCount = iCount + 1
        Next Rng
        
      ' Write the extracted values into the correct row of the destination range
      With Application.Workbooks(DestBookName).Sheets(ToPageIndex)
         Col_offset = 1
               
         ' If the Add Sheet Names Flag is set then write the present sheet name
         ' And add one to the Column Offset to begin writing the cell values
         If AddNamesFlag Then
           .Range(DestRangeText).Cells(Row_offset, Col_offset).Value = ThisPageName
           Col_offset = Col_offset + 1
         End If
       
         ' Now write the cell values (and formats if flag selected) into the destination range
         For iCount = 0 To NumberOfItems - 1
           .Range(DestRangeText).Cells(Row_offset, Col_offset).Value = ExtractValues(iCount)
           If PasteFormatsFlag Then
              .Range(DestRangeText).Cells(Row_offset, Col_offset).NumberFormat = RangeFormats(iCount)
           End If
           Col_offset = Col_offset + 1
         Next iCount
      End With
    
      'Increment the Row Offset to prepare to write the values from the next page into
      ' the next available row
      Row_offset = Row_offset + 1 + SpaceBetweenLines
    
    Next ThisSheetIndex
 
End Sub


' THE MAIN SUB-ROUTINES FOR THE DATA EXTRACTION PROGRAM
'
'
' The CheckParameters Function
' Returns True if Parameters are all OK
'
Function CheckParameters()
Dim NoProblems As Boolean
  NoProblems = True
  With Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue")
    BookIndex = .DropDowns("DDLBookFrom").ListIndex
    SourceBookName = .DropDowns("DDLBookFrom").List(BookIndex)
    Set SourceBook = Application.Workbooks(SourceBookName)
    SourceRangeText = .EditBoxes("EdBoxExtractRange").Text
    StartPageIndex = Val(.EditBoxes("EdBoxStartPage").Text)
    EndPageIndex = Val(.EditBoxes("EdBoxEndPage").Text)
    Set SourceSheet = SourceBook.Sheets(StartPageIndex)
    If SourceRangeText = "" Then
       Response = MsgBox("You must specify the range to be copied from")
       NoProblems = False
    End If
    
    If NoProblems Then
       Set SourceRange = SourceSheet.Range(SourceRangeText)
       NumberOfItems = SourceRange.Count
       If SourceRange.Count < 1 Then
         Response = MsgBox("There must be at least one cell in the" & _
                         "Range to be copied from")
         NoProblems = False
       End If
    End If
    

    BookIndex = .DropDowns("DDDestBook").ListIndex
    DestBookName = .DropDowns("DDDestBook").List(BookIndex)
    Set DestBook = Application.Workbooks(DestBookName)
    ToPageIndex = Val(.EditBoxes("EdBoxDestSheet").Text)
    Set DestSheet = DestBook.Sheets(ToPageIndex)
    
    If NoProblems = True Then
       DestRangeText = .EditBoxes("EdBoxDestCell").Text
       If DestRangeText = "" Then
          Response = MsgBox("You must specify the cell in the top" & _
                          "left hand corner of the area into which" & _
                          " the information is to be copied ")
          NoProblems = False
       End If
    End If
    
    If NoProblems = True Then
       Set DestRange = DestSheet.Range(DestRangeText)
       If DestRange.Count <> 1 Then
         Response = MsgBox("You must specify a single cell for the top" & _
                    "left hand corner of the area into which the data" & _
                    "is to be copied:   e.g.   A5 ")
         NoProblems = False
       End If
    End If

    SpaceBetweenLines = Val(.EditBoxes("EdBoxGap").Text)
    If NoProblems = True Then
      If SpaceBetweenLines < 0 Then
         Response = MsgBox("Please set a value of 0 or above for" & _
                           " the gap between each line copied ")
         NoProblems = False
      End If
    End If
    PasteFormatsFlag = (.CheckBoxes("ChBoxPasteFormats").Value = xlOn)
    AddNamesFlag = (.CheckBoxes("ChBoxAddNames").Value = xlOn)
    AddCellRefFlag = (.CheckBoxes("ChBoxAddCellRef").Value = xlOn)
  End With
  
  'Check that the Destination range is Empty'
  
  With Application.Workbooks(DestBookName).Sheets(ToPageIndex)
    tmpCount = 0
    tmpFlag = True
    tmpColInc = 0
    tmpRowInc = 0
        
    Set currentCell = .Range(DestRangeText)
    
    If Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue").CheckBoxes("ChBoxAddNames").Value = xlOn Then
         tmpColInc = 1
    End If
    
    If Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue").CheckBoxes("ChBoxAddCellRef").Value = xlOn Then
         tmpRowInc = 1
    End If
    
        
    For colCount = 0 To (NumberOfItems + tmpColInc - 1)
      For rowCount = 0 To (SpaceBetweenLines + 1) * (EndPageIndex - StartPageIndex + tmpRowInc)
        
        Set nextCell = currentCell.Offset(rowCount, colCount)
        'Offset is in the form .Offset(rowOffset, ColOffset)'
        
        If Not (IsEmpty(nextCell)) Then
            tmpCount = tmpCount + 1
        End If
      Next rowCount
    Next colCount
                 
    If (tmpCount > 0) Then
      TmpString = "There are values in the destination range in sheet "
      TmpString = TmpString + DestSheetText
      TmpString = TmpString + "  in  "
      TmpString = TmpString + DestBookName
      Response = MsgBox(TmpString, vbOKCancel, "Non Empty Destination Range", 0, 0)
      NoProblems = False
    End If
  End With
  CheckParameters = NoProblems

End Function






'
' The first Dialogue subroutine to initialise the dialogue
'
'
Private Sub InitialiseDialogue()
Dim iCount As Integer
Dim bk As Variant
Dim BookIndex As Integer

  For iCount = 0 To 10
    Workbooks(MacroWorkbookName).Worksheets("OpenBookList").Cells(4 + iCount, 2).Value = ""
  Next iCount
  iCount = 0
  For Each bk In Workbooks
    Workbooks(MacroWorkbookName).Worksheets("OpenBookList").Cells(4 + iCount, 2).Value = bk.Name
    iCount = iCount + 1
  Next bk
  
  
' Set the starting values for the first time using the extract dialogue
  OpenBooksCount = Workbooks.Count
  With Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue")
      .CheckBoxes("ChBoxPasteFormats") = False
      .CheckBoxes("ChBoxAddNames") = False
      BookIndex = .DropDowns("DDLBookFrom").ListIndex
      If BookIndex > OpenBooksCount Then
        BookIndex = OpenBooksCount
        .DropDowns("DDLBookFrom").ListIndex = BookIndex
      End If
      Set SourceBook = Workbooks(BookIndex)
      SourceBookSheetsCount = SourceBook.Sheets.Count
         .Spinners("SpStartPage").Value = 1
         StartPageIndex = 1
         .Spinners("SpStartPage").Max = SourceBookSheetsCount
         .Spinners("SpEndPage").Value = SourceBookSheetsCount
         EndPageIndex = SourceBookSheetsCount
         .Spinners("SpEndPage").Max = SourceBookSheetsCount
         .EditBoxes("EdBoxStartPage").Text = StartPageIndex
         .EditBoxes("EdBoxEndPage").Text = EndPageIndex
         
      BookIndex = .DropDowns("DDDestBook").ListIndex
      If BookIndex > OpenBooksCount Then
        BookIndex = OpenBooksCount
        .DropDowns("DDDestBook").ListIndex = BookIndex
      End If
      Set DestBook = Workbooks(BookIndex)
      DestBookSheetsCount = DestBook.Sheets.Count
         .Spinners("SpDestSheet").Value = 1
         ToPageIndex = 1
         .Spinners("SpDestSheet").Max = DestBookSheetsCount
         .EditBoxes("EdBoxDestSheet").Text = ToPageIndex
     
  End With
End Sub


'
' DialogFrame1_Show Macro
'
'
Sub DialogFrame1_Show()
' Safer to set paste formats and add names to False each time the
' Dialogue is re-shown
  With Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue")
      .CheckBoxes("ChBoxPasteFormats") = False
      .CheckBoxes("ChBoxAddNames") = False
' Reset the Sourcebook and its size in case there have been
' Changes since the last time
      BookIndex = .DropDowns("DDLBookFrom").ListIndex
      Set SourceBook = Workbooks(BookIndex)
      SourceBookSheetsCount = SourceBook.Sheets.Count
      If .Spinners("SpStartPage").Value > SourceBookSheetsCount Then
         .Spinners("SpStartPage").Value = 1
          StartPageIndex = 1
         .EditBoxes("EdBoxStartPage").Text = StartPageIndex
      End If
      If .Spinners("SpEndPage").Value > SourceBookSheetsCount Then
         .Spinners("SpEndPage").Value = SourceBookSheetsCount
         EndPageIndex = SourceBookSheetsCount
         .EditBoxes("EdBoxEndPage").Text = EndPageIndex
      End If
      If .Spinners("SpDestSheet").Value > DestBookSheetsCount Then
         .Spinners("SpDestSheet").Value = 1
         ToPageIndex = 1
         .EditBoxes("EdBoxDestSheet").Text = ToPageIndex
      End If
  End With
  UpdateSourceBookDisplay
  UpdateDestBookDisplay
End Sub

' SpStartPage_Change Macro
'
'
Sub SpStartPage_Change()
 UpdateSourceBookDisplay
End Sub


'
' SpEndPage_Change Macro
'
'
Sub SpEndPage_Change()
  UpdateSourceBookDisplay
End Sub

'
' SpDestSheet_Change Macro
'
'
Sub SpDestSheet_Change()
 UpdateDestBookDisplay
End Sub

'
' EdBoxStartPage_Change Macro
'
'
Sub EdBoxStartPage_Change()
Dim TempVal As Integer
   With DialogSheets("ExtractDialogue")
    TempVal = Val(.EditBoxes("EdBoxStartPage").Text)
    .Spinners("SpStartPage").Value = TempVal
   End With
   UpdateSourceBookDisplay
End Sub


'
' EdBoxEndPage_Change Macro
'
'
Sub EdBoxEndPage_Change()
Dim TempVal As Integer
   With DialogSheets("ExtractDialogue")
    TempVal = Val(.EditBoxes("EdBoxEndPage").Text)
    .Spinners("SpEndPage").Value = TempVal
   End With
   UpdateSourceBookDisplay
End Sub
'
' EdBoxDestSheet_Change Macro
'
'
Sub EdBoxDestSheet_Change()
Dim TempVal As Integer
   With DialogSheets("ExtractDialogue")
    TempVal = Val(.EditBoxes("EdBoxDestSheet").Text)
    .Spinners("SpDestSheet").Value = TempVal
   End With
   UpdateDestBookDisplay
End Sub

'
' DDLBookFrom_Change Macro
'
'
Sub DDLBookFrom_Change()
 ResetBookFromLimits
 UpdateSourceBookDisplay
End Sub

'
' DDDestBook_Change Macro
'
'
Sub DDDestBook_Change()
  ResetDestBookLimits
  UpdateDestBookDisplay
End Sub

'
' Button3_Click Macro
'
'
Sub BtnCancel_Click()
 CancelFlag = True
 
End Sub



Sub ResetBookFromLimits()
Dim BookIndex As Integer
 With Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue")
   BookIndex = .DropDowns("DDLBookFrom").ListIndex
   Set SourceBook = Workbooks(BookIndex)
   SourceBookSheetsCount = SourceBook.Sheets.Count
   .Spinners("SpStartPage").Max = SourceBookSheetsCount
   If .Spinners("SpStartPage").Value > SourceBookSheetsCount Then
         .Spinners("SpStartPage").Value = 1
          StartPageIndex = 1
         .EditBoxes("EdBoxStartPage").Text = StartPageIndex
   End If
   .Spinners("SpEndPage").Max = SourceBookSheetsCount
   If .Spinners("SpEndPage").Value > SourceBookSheetsCount Then
        .Spinners("SpEndPage").Value = SourceBookSheetsCount
        EndPageIndex = SourceBookSheetsCount
        .EditBoxes("EdBoxEndPage").Text = EndPageIndex
   End If
 End With
End Sub

Sub ResetDestBookLimits()
Dim BookIndex As Integer
 With Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue")
   BookIndex = .DropDowns("DDDestBook").ListIndex
   Set DestBook = Workbooks(BookIndex)
   DestBookSheetsCount = DestBook.Sheets.Count
   .Spinners("SpDestSheet").Max = DestBookSheetsCount
   If .Spinners("SpDestSheet").Value > DestBookSheetsCount Then
         .Spinners("SpDestSheet").Value = 1
         DestPageIndex = 1
         .EditBoxes("EdBoxDestSheet").Text = DestPageIndex
   End If
 End With
End Sub

Sub UpdateSourceBookDisplay()
Dim TempVal As Integer
Dim BookIndex As Integer
Dim TSheetName As String
   With Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue")
     BookIndex = .DropDowns("DDLBookFrom").ListIndex
     Set SourceBook = Workbooks(BookIndex)
     
     TempVal = .Spinners("SpStartPage").Value
     .EditBoxes("EdBoxStartPage").Text = TempVal
     TSheetName = SourceBook.Sheets(TempVal).Name
     .Labels("LblFromSheetName").Text = TSheetName
     
     TempVal = .Spinners("SpEndPage").Value
     .EditBoxes("EdBoxEndPage").Text = TempVal
     TSheetName = SourceBook.Sheets(TempVal).Name
     .Labels("LblToSheetName").Text = TSheetName
   End With
End Sub



Sub UpdateDestBookDisplay()
Dim TempVal As Integer
Dim BookIndex As Integer
Dim TSheetName As String
   With Workbooks(MacroWorkbookName).DialogSheets("ExtractDialogue")
     TempVal = .Spinners("SpDestSheet").Value
     .EditBoxes("EdBoxDestSheet").Text = TempVal
      BookIndex = .DropDowns("DDDestBook").ListIndex
      Set DestBook = Workbooks(BookIndex)
      TSheetName = DestBook.Sheets(TempVal).Name
      .Labels("LblDestPage").Text = TSheetName
      DestSheetText = TSheetName
   End With
End Sub

 

[VoG]

Essentially it is expecting the active workbook to contain a sheet called OpenBookList. Try adding a blank sheet with that name.

 

[cheekbones3]

Essentially it is expecting the active workbook to contain a sheet called OpenBookList. Try adding a blank sheet with that name.

Have found a workbook which contains the relevant worksheets now. This solves the earlier problems, as the macro assumes that this workbook is open - it contains the dialogue table too which then points the code at the relevant data ranges.

However, the first line in "Sub DialogFrame1_Show()" is now giving a type mismatch. Is this a problem with the way the dialogue box has been created?

 

[VoG]

It is also expecting a dialog sheet called ExtractDialogue to be present (and to be populated with the controls that it references).

Dialog sheets are the predecessor of userforms but they will still work in later (97 on) versions of Excel.

I think you'll need to find a workbook that contains this dialog sheet and copy it. Note that it will almost certainly be hidden.

 

[cheekbones3]

It is also expecting a dialog sheet called ExtractDialogue to be present (and to be populated with the controls that it references).

Dialog sheets are the predecessor of userforms but they will still work in later (97 on) versions of Excel.

I think you'll need to find a workbook that contains this dialog sheet and copy it. Note that it will almost certainly be hidden.

I should have mentioned that that particular sheet is present as well, hence the type mismatch rather than subscript out of range.

 

[VoG]

Sorry, which line of code is giving the mismatch error?