vba - 如何使用 Excel 2007 从受密码保护和关闭的工作簿中获取数据

Question

我在 Excel 2007 上使用 ADO 从关闭的工作簿中获取数据，代码(无论文件和工作表名称如何)是:

<小时/>

Sub TransferData()
Dim sourceFile As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
sourceFile = "C:\Bel.xls"
GetData sourceFile, "Daily Figures", "A13:j102", Sheets("Data -   Daily").Range("N2"), False, False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

<小时/>

Public Sub GetData(sourceFile As Variant, SourceSheet As String, _
        SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
' http://www.rondebruin.nl/ado.htm
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                "Extended Properties=""Excel 8.0;HDR=No"";"
Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & sourceFile & ";" & _
                "Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
    If Val(Application.Version) < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                "Data Source=" & sourceFile & ";" & _
                "Extended Properties=""Excel 8.0;HDR=Yes"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & sourceFile & ";" & _
                "Extended Properties=""Excel 12.0;HDR=Yes"";"
    End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
    ' worksheet level name or range
    szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
    If Header = False Then
        TargetRange.Cells(1, 1).CopyFromRecordset rsData
    Else
        'Add the header cell in each column if the last argument is True
        If UseHeaderRow Then
             For lCount = 0 To rsData.Fields.Count - 1
                TargetRange.Cells(1, 1 + lCount).Value = _
                rsData.Fields(lCount).Name
             Next lCount
            TargetRange.Cells(2, 1).CopyFromRecordset rsData
        Else
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        End If
    End If
Else
    MsgBox "No records returned from : " & sourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " &   sourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0
End Sub

<小时/>

上面的代码不适用于受密码保护的 woorkbook，我也有管理密码的代码，但我真的不知道把它们放在哪里

Sub open_file ()
Workbooks.Open Filename:="C:\Bel.xls", password:="123"
End sub

<小时/>

Workbooks.Open Filename:="C:\Bel.xls", Password:="Password"

Answer 1

我想我通过使用这个找到了答案:

End Sub
Sub TransferData()
Dim sourceFile As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

sourceFile = "C:\.xls"    Yuor SourceFile Address

Dim xl As Object
Set xl = GetObject(sourceFile)

GetData sourceFile, "YourSourceSheetName", "YourSourceDataRange", Sheets("YourDestinationSheetName").Range("YourDestinationRange"), False,  False

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

If xl.Application.Workbooks.Count > 1 Then
   xl.Close False  ' close workbook, do not save
   Else
   xl.Application.Quit  ' close excel
End If

End Sub

Public Sub GetData(sourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
' http://www.rondebruin.nl/ado.htm

Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

' Create the connection string.
If Header = False Then
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=No"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                    "Extended Properties=""Excel 12.0;HDR=No"";"
    End If
Else
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=Yes"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                    "Extended Properties=""Excel 12.0;HDR=Yes"";"
    End If
End If

If SourceSheet = "" Then
    ' workbook level name
    szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
    ' worksheet level name or range
    szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If

On Error GoTo SomethingWrong

Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")

rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1

' Check to make sure we received data and copy the data
If Not rsData.EOF Then

    If Header = False Then
        TargetRange.Cells(1, 1).CopyFromRecordset rsData
    Else
        'Add the header cell in each column if the last argument is True
        If UseHeaderRow Then
            For lCount = 0 To rsData.Fields.Count - 1
                TargetRange.Cells(1, 1 + lCount).Value = _
                rsData.Fields(lCount).Name
            Next lCount
            TargetRange.Cells(2, 1).CopyFromRecordset rsData
        Else
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        End If
    End If

Else
    MsgBox "No records returned from : " & sourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & sourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0

End Sub

感谢大家