使用类似于 QueryTable 的东西导入 excel 文件？

Posted 2023-04-19

【中文标题】使用类似于 QueryTable 的东西导入 excel 文件？

【英文标题】：import excel file using something similiar to QueryTable?

【发布时间】：2017-06-26 03:35:32

【问题描述】：

要将数据导入 excel 文件，QueryTable 在源为 .csv 文件时非常方便，例如Import csv with quoted newline using QueryTables in Excel ，但它不适用于 excel 源代码。

导入一个excel文件can be done by VBA，只是想知道，如果有像QueryTable这样方便的东西，可以从一个excel文件中导入，s.t。只需要指定源文件名、工作表名或范围名？

【参考方案1】：

哦，我明白了。好的，您可以使用 VBA 将 Worksheets 中的数据导入您的 Workbook。

' Get customer workbook...
Dim customerBook As Workbook
Dim filter As String
Dim caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetWorkbook As Workbook

' make weak assumption that active workbook is the target
Set targetWorkbook = Application.ActiveWorkbook

' get the customer workbook
filter = "Text files (*.xlsx),*.xlsx"
caption = "Please Select an input file "
customerFilename = Application.GetOpenFilename(filter, , caption)

Set customerWorkbook = Application.Workbooks.Open(customerFilename)

' assume range is A1 - C10 in sheet1
' copy data from customer to target workbook
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets(1)
Dim sourceSheet As Worksheet
Set sourceSheet = customerWorkbook.Worksheets(1)

targetSheet.Range("A1", "C10").Value = sourceSheet.Range("A1", "C10").Value

' Close customer workbook
customerWorkbook.Close

或者，您可以使用查询工具从另一个 Excel 文件中导入数据。

http://dailydoseofexcel.com/archives/2004/12/13/parameters-in-excel-external-data-queries/

【参考方案2】：

我猜您正在将数据从 Access 导入到 excel 中。我认为您没有指定来源，或者我无法弄清楚。我的眼睛不像以前那么好了……

无论如何，请考虑这个选项。

Sub ADOImportFromAccessTable(DBFullName As String, _
    TableName As String, TargetRange As Range)
' Example: ADOImportFromAccessTable "C:\FolderName\DataBaseName.mdb", _
    "TableName", Range("C1")
Dim cn As ADODB.Connection, rs As ADODB.Recordset, intColIndex As Integer
    Set TargetRange = TargetRange.Cells(1, 1)
    ' open the database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
        DBFullName & ";"
    Set rs = New ADODB.Recordset
    With rs
        ' open the recordset
        .Open TableName, cn, adOpenStatic, adLockOptimistic, adCmdTable 
        ' all records
        '.Open "SELECT * FROM " & TableName & _
            " WHERE [FieldName] = 'MyCriteria'", cn, , , adCmdText 
        ' filter records

        RS2WS rs, TargetRange ' write data from the recordset to the worksheet

'        ' optional approach for Excel 2000 or later (RS2WS is not necessary)
'        For intColIndex = 0 To rs.Fields.Count - 1 ' the field names
'            TargetRange.Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
'        Next
'        TargetRange.Offset(1, 0).CopyFromRecordset rs ' the recordset data

    End With
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

或者，这个。

Sub RS2WS(rs As ADODB.Recordset, TargetCell As Range)
Dim f As Integer, r As Long, c As Long
    If rs Is Nothing Then Exit Sub
    If rs.State <> adStateOpen Then Exit Sub
    If TargetCell Is Nothing Then Exit Sub

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .StatusBar = "Writing data from recordset..."
    End With

    With TargetCell.Cells(1, 1)
        r = .Row
        c = .Column
    End With

    With TargetCell.Parent
        .Range(.Cells(r, c), .Cells(.Rows.Count, c + rs.Fields.Count - 1)).Clear 
        ' clear existing contents
        ' write column headers
        For f = 0 To rs.Fields.Count - 1
            On Error Resume Next
            .Cells(r, c + f).Formula = rs.Fields(f).Name
            On Error GoTo 0
        Next f
        ' write records
        On Error Resume Next
        rs.MoveFirst
        On Error GoTo 0
        Do While Not rs.EOF
            r = r + 1
            For f = 0 To rs.Fields.Count - 1
                On Error Resume Next
                .Cells(r, c + f).Formula = rs.Fields(f).Value
                On Error GoTo 0
            Next f
            rs.MoveNext
        Loop
        .Rows(TargetCell.Cells(1, 1).Row).Font.Bold = True
        .Columns("A:IV").AutoFit
    End With

    With Application
        .StatusBar = False
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub