如何在不打开整个 excel 工作簿的情况下只复制值？

Question

我想在不打开整个工作簿的情况下制作一个只有值的副本。

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

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

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

Answer 1

我已经创建了一个有效的 VBA 脚本，允许用户 select 工作簿并在不打开它的情况下制作一个只有值的副本。

我现在可以非常快速地制作整个工作簿的唯一值副本。结果是一个快速、轻便、可用的工作簿。

主子

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

辅助函数：

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

如何在不打开整个 excel 工作簿的情况下只复制值？

How can I copy the values only from an entire excel workbook without opening it?

excel

vba

copy

adodb