4
\$\begingroup\$

I have created a working VBA script that allows the user to select a workbook and make a values only copy of it without opening it. This is useful for getting data from a workbook that is very slow to open. From here: https://stackoverflow.com/questions/63398348/how-can-i-copy-the-values-only-from-an-entire-excel-workbook-without-opening-it/

I can very quickly make a values only copy of an entire workbook. The result is a fast, lightweight, usable workbook that only contains values from the original workbook.

I want to know if there are ways I can/should improve what I have done.

I also want to know if there is a simpler way to achieve the same result.

Main Sub

Public Sub Copy_Workbook_Values_Only()
    On Error GoTo ErrorHandler
    
    Dim intCount    As Integer
    Dim firstSheet  As Boolean
    Dim sheetname   As String
    Dim trimmedname As String
    
    Dim db          As ADODB.Connection, rs As ADODB.Recordset
    Set db = New ADODB.Connection
    Set rs = New ADODB.Recordset
    Set rsSheet = New ADODB.Recordset
    
    Dim wbnew       As Workbook
    
    ExcelFileFullPath = PickFile()
    If ExcelFileFullPath = "" Then Exit Sub
    
    Dim strcon      As String
    strcon = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ExcelFileFullPath & ";Extended Properties=""Excel 12.0 Xml;HDR=NO;"""
    db.Open (strcon)
    
    Set wbnew = Workbooks.Add(xlWBATWorksheet)        'should make just one sheet in new workbook
    firstSheet = True
    
    Set rs = db.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table"))
    
    Do While Not rs.EOF
        sheetname = rs!TABLE_NAME
        
        'must be a better way to get only sheets
        'ADO filter does not support "ends with"
        'I would like a way to either return only sheets (no named ranges) or filter for the same
        'currently just check to see if last character is a $
        If IsNotWorksheet(sheetname) Then GoTo NextIteration
        
        'get rid of any illegal or extra characters added to worksheet name
        trimmedname = Sanitize_Worksheet_Name(sheetname)
        
        If firstSheet Then
            Set currentSheet = wbnew.Sheets(1)
            firstSheet = False
        Else
            If WorksheetExists(trimmedname) Then GoTo NextIteration        'skip if name somehow already exists
            Set currentSheet = wbnew.Sheets.Add(After:=ActiveSheet)
        End If
        
        currentSheet.name = trimmedname
        
        'get data and write to worksheet
        SQLCompound = "SELECT * FROM [" & sheetname & "]"
        rsSheet.Open SQLCompound, db, adOpenStatic, adLockReadOnly, adCmdText
        currentSheet.Range("a1").CopyFromRecordset rsSheet
        rsSheet.Close
        
NextIteration:
        rs.MoveNext
    Loop
    
    rs.Close
    db.Close
    
    Exit Sub
    
ErrorHandler:
    If Not db Is Nothing Then
        If db.State = adStateOpen Then db.Close
    End If
    Set db = Nothing
    
    If Err <> 0 Then
        MsgBox Err.Source & "-->" & Err.Description, , "Error"
    End If
End Sub

Helper Functions:

Private Function PickFile() As String
    ' Create and set the file dialog object.
    Dim fd          As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    Set objSFolders = CreateObject("WScript.Shell").SpecialFolders
    
    With fd
        .Filters.Clear        ' Clear all the filters (if applied before).
        
        ' Give the dialog box a title, word for doc or Excel for excel files.
        .Title = "Select an Excel File"
        
        ' Apply filter to show only a particular type of files.
        .Filters.Add "Excel Files", "*.xls;*.xlsx;*.xlsm", 1
        .Filters.Add "All Excel Files", "*.xlsx;*.xlsm;*.xlsb;*.xltx;*.xltm;*.xls;*.xlt;*.xls;*.xml;*.xml;*.xlam;*.xla;*.xlw;*.xlr", 2
        .Filters.Add "All Files", "*.*", 3
        
        ' Do not allow users to select more than one file.
        .AllowMultiSelect = False
        
        .InitialFileName = objSFolders("mydocuments")
        
        ' Show the file.
        If .Show = True Then
            PickFile = .SelectedItems(1)        ' Get the complete file path.
        End If
    End With
End Function
Private Function Sanitize_Worksheet_Name(sheetname As String) As String
    
    result = sheetname
    If Left(result, 1) = Chr(39) And Right(result, 1) = Chr(39) Then        'name has been wrapped in single quotes
    result = Mid(result, 2, Len(result) - 2)
End If

If Right(result, 1) = "$" Then        'remove trailing $
result = Left(result, Len(result) - 1)
End If

'Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(7) = ":"
For i = 1 To 7
    result = Replace(result, IllegalCharacter(i), "")
Next i

result = Left(result, 31)        'no more than 31 chars

Sanitize_Worksheet_Name = result
End Function
Private Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht         As Worksheet
    
    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
    
End Function
'probably a better way for checking for this
'sheetnames from database end in $, but may have a trailing quote after
'tables/named ranges cannot have $ in their name in excel
'tables/named ranges will only have an interior $ -- after the sheetname, but before the range name
Private Function IsNotWorksheet(sheetname As String) As Boolean
    i = 0
    If Right(sheetname, 1) = Chr(39) Then i = 1        'ignore trailing single quote
    If Mid(sheetname, Len(sheetname) - i, 1) <> "$" Then        'not a sheet
    IsNotWorksheet = True
Else
    IsNotWorksheet = False
End If
End Function

Here is a link to the pertinent post about not being able to use an "ends with" filter: https://stackoverflow.com/questions/55632420/vba-recordset-filter-wildcard-ending-with-not-working-error-3001

\$\endgroup\$

1 Answer 1

2
\$\begingroup\$

I was able to greatly simplify the code using ADOX.Catalog to pull sheets instead of trying to figure out what is or is not a sheet. I also added code that will allow you to open any type of Excel file and always have the correct SQL connection string.

I have some general notes here for you:

  • Use RubberDuck to format your code and help you review
  • Never use underscore "_" in procedure name because those are reserved for VBA events.
  • Only one declaration per Dim
  • Use Late-bound objects for code portablility
  • Use Option Explicit to force you to declare all your variables
  • Don't use Goto when you can use If

Here is my version of the code:

Option Explicit

' Set all external enums for late bound compatibility
Const adOpenStatic As Long = 3
Const adLockReadOnly As Long = 1
Const adCmdText As Long = 1
Const adStateOpen As Long = 1

Public Sub CopyWorkbookValuesOnly()
    ' Handle requirements first
    Dim excelFileFullPath As String
    excelFileFullPath = PickFile
    
    If excelFileFullPath = vbNullString Then Exit Sub
    
    On Error GoTo ErrorHandler

    Dim excelDB          As Object
    Set excelDB = CreateObject("ADODB.Connection")
    excelDB.Open GetConnectionString(excelFileFullPath)
    
    Dim wbnew       As Workbook
    Set wbnew = Workbooks.Add(xlWBATWorksheet)   'should make just one sheet in new workbook

    ' Get all the Sheets
    Dim sheetTabs As Object
    With CreateObject("ADOX.Catalog")
        .ActiveConnection = excelDB
        Set sheetTabs = .Tables
    End With
    
    Dim firstSheet As Boolean
    firstSheet = True
    Dim tableSheet As Object
    For Each tableSheet In sheetTabs
        Dim trimmedname As String
        If Left$(tableSheet.Name, 1) = Chr$(39) And Right$(tableSheet.Name, 1) = Chr$(39) Then ' the name has been wrapped in single quotes
            trimmedname = Mid$(tableSheet.Name, 2, Len(tableSheet.Name) - 2)
        Else ' start with just the name
            trimmedname = tableSheet.Name
        End If
        
        If Right$(trimmedname, 1) = "$" Then
            trimmedname = SanitizeWorksheetName(trimmedname)
            Dim currentSheet As Worksheet
            If firstSheet Then
                Set currentSheet = wbnew.Sheets(1)
                firstSheet = False
            Else
                Set currentSheet = wbnew.Sheets.Add(After:=ActiveSheet)
            End If
            
            currentSheet.Name = trimmedname
            
            'get data and write to worksheet
            Dim sqlCompound As String
            sqlCompound = "SELECT * FROM [" & tableSheet.Name & "]"
            
            Dim rsSheet As Object
            Set rsSheet = CreateObject("ADODB.Recordset")
            rsSheet.Open sqlCompound, excelDB, adOpenStatic, adLockReadOnly, adCmdText
            currentSheet.Range("A1").CopyFromRecordset rsSheet
            rsSheet.Close
            Set rsSheet = Nothing
        End If
    Next tableSheet
      
ErrorHandler:
    If Not excelDB Is Nothing Then
        If excelDB.State = adStateOpen Then excelDB.Close
        Set excelDB = Nothing
    End If
    
    If Err.Number <> 0 Then
        MsgBox Err.Source & "Error number: " & Err.Number & "-->" & Err.Description, , "Error"
    End If
End Sub

Private Function PickFile() As String
    ' Create and set the file dialog object.
    Dim specialFolder As Object
    Set specialFolder = CreateObject("WScript.Shell").SpecialFolders
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear                           ' Clear all the filters (if applied before).
        
        ' Give the dialog box a title, word for doc or Excel for excel files.
        .Title = "Select an Excel File"
        
        ' Apply filter to show only a particular type of files.
        .Filters.Add "Excel Files", "*.xls;*.xlsx;*.xlsm", 1
        .Filters.Add "All Excel Files", "*.xlsx;*.xlsm;*.xlsb;*.xltx;*.xltm;*.xls;*.xlt;*.xls;*.xml;*.xml;*.xlam;*.xla;*.xlw;*.xlr", 2
        .Filters.Add "All Files", "*.*", 3
        
        ' Do not allow users to select more than one file.
        .AllowMultiSelect = False
        
        .InitialFileName = specialFolder("MyDocuments")
        
        ' Show the file.
        If .Show = True Then
            PickFile = .SelectedItems.Item(1)         ' Get the complete file path.
        End If
    End With
End Function

Private Function SanitizeWorksheetName(ByVal sheetName As String) As String
    Dim result As String
    result = sheetName

    If Right$(result, 1) = "$" Then               'remove trailing $
        result = Left$(result, Len(result) - 1)
    End If
    
    ' Remove illegal characters using RegEx
    Const IllegalCharacters As String = "\/\\\[\]\*:"
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = IllegalCharacters
        result = .Replace(result, vbNullString)
    End With
    
    ' keep only 31 characters
    SanitizeWorksheetName = Left$(result, 31)
End Function

Public Function GetConnectionString(ByVal fileName As String) As String
    Dim fileExtension As String
    fileExtension = Right$(fileName, Len(fileName) - InStrRev(fileName, "."))
    Dim provider As String
    provider = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
    Dim connectionString As String
    Select Case fileExtension
    Case "xls"
        connectionString = provider & fileName & ";Extended Properties=""Excel 8.0;HDR=NO;IMEX=1"";"
    Case "xlsx"
        connectionString = provider & fileName & ";Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"
    Case "xlsb"
        connectionString = provider & fileName & ";Extended Properties=""Excel 12.0;HDR=NO;IMEX=1"";"
    Case "xlsm"
        connectionString = provider & fileName & ";Extended Properties=""Excel 12.0 Macro;HDR=NO;IMEX=1"";"
    Case Else
        connectionString = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & fileName & ";"
    End Select
    
    GetConnectionString = connectionString
End Function
\$\endgroup\$
8
  • \$\begingroup\$ This code chokes on my original use case - a spreadsheet with (thousands?) of named ranges. It makes a tab for each of the named ranges, not just each of the sheets. Also, if the original workbook contains a Sheet1 it errors out as the new workbook already has a sheet1 and cannot make another by the same name. \$\endgroup\$
    – S. Melted
    Aug 13, 2020 at 18:37
  • \$\begingroup\$ However, I did really appreciate your feedback overall and will incorporate what I can. \$\endgroup\$
    – S. Melted
    Aug 13, 2020 at 18:38
  • \$\begingroup\$ You can only have one sheet named "Sheet1" and it does come with one. The name should be set on each pass so you won't ever have a collision. I've tested that much. I need to test the named ranges. I will have to make an example workbook to see what you are talking about. \$\endgroup\$
    – HackSlash
    Aug 13, 2020 at 18:40
  • \$\begingroup\$ Ok, @S.Melted, please try this latest version. It should ignore named ranges as you expect. \$\endgroup\$
    – HackSlash
    Aug 13, 2020 at 18:44
  • \$\begingroup\$ It now snappily goes through the original workbook with thousands of named ranges. However, I made a worksheet with two tabs named "ab" and "12". It will import "ab" but not "12" because it wraps 12$ in single quotes for the tableSheet.name making the last character a single quote, not a $. \$\endgroup\$
    – S. Melted
    Aug 13, 2020 at 18:54

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.