如何仅从整个excel工作簿复制值而不打开它？

我想在不打开整个工作簿的情况下创建一个仅值副本

我必须与一个需要30多分钟才能打开的巨大工作簿中的数据进行交互

老实说，我甚至不知道为什么要花这么长时间才能打开，因为我在30分钟后就放弃了——我从来没有成功打开过它

---

显然，我不能使用任何打开工作簿的方法，因为这需要花费太长的时间。

我创建了一个工作VBA脚本，允许用户选择一个工作簿，并在不打开它的情况下对其进行值复制

我现在可以很快地为整个工作簿制作一个仅值副本。结果是一个快速、轻量级、可用的工作簿

主接头

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

---

这是对你问题的回答还是问题的这一部分？如果这是问题的一部分，请编辑问题并将代码放在那里。@FunThomas这实际上是一个由两部分组成的问题。1如何做回答2如何改进/是否有更好的方法。如果你认为有更好的方式来安排或表达这一点，我洗耳恭听。我反复讨论是将其作为问题的一部分还是使用Q&A选项。我应该考虑将其转换为代码审查，溢出用于解决问题，代码审查，顾名思义，是或代码审查删除了与代码审查相关的问题部分。现在只是一个问题和一个答案。

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