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

如何解决如何仅从整个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,"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

助手功能：

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