如何在VBA中不打开Excel工作簿的情况下检索数据？

Question

我有一个文件夹，可以让用户进行选择，其中包含128个文件。在我的代码中，我打开每个文档并将相关数据复制到我的主工作簿中。所有这些都是通过用户界面控制的。我的问题是完成此过程所需的时间（约50秒）- 我肯定可以在不打开文档的情况下完成它吗？

以下代码用于选择要搜索的目录：

Private Sub CBSearch_Click()
Dim Count1 As Integer

    ChDir "Directory"
    ChDrive "C"
    Count1 = 1

    inputname = Application.GetOpenFilename("data files (*.P_1),*.P_1")

    TBFolderPath.Text = CurDir()

End Sub

这将获取文件：

Private Sub CBRetrieve_Click()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim i As Integer
Dim StrLen As Integer
Dim Folder As String
Dim A As String
Dim ColRef As Integer

Open_Data.Hide

StrLen = Len(TBFolderPath) + 1
Folder = Mid(TBFolderPath, StrLen - 10, 10)

For i = 1 To 128
A = Right("000" & i, 3)
    If Dir(TBFolderPath + "\" + Folder + "-" + A + ".P_1") <> "" Then
        Workbooks.OpenText Filename:= _
            TBFolderPath + "\" + Folder + "-" + A + ".P_1" _
            , Origin:=xlMSDOS, StartRow:=31, DataType:=xlDelimited, TextQualifier:= _
            xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
            Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
            Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True

        Columns("B:B").Delete Shift:=xlToLeft
        Rows("2:2").Delete Shift:=xlUp

        Range(Range("A1:B1"), Range("A1:B1").End(xlDown)).Copy

        Windows("Document.xls").Activate

        ColRef = (2 * i) - 1

        Cells(15, ColRef).Select
        ActiveSheet.Paste

        Windows(Folder + "-" + A + ".P_1").Activate
        ActiveWindow.Close
    End If
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

TBFolderPath 是用户窗体中文本框的内容，也是文件位置的所在地。

抱歉我的代码很乱！

编辑： 数据示例：

TA2000 PLOT DATA FILE
FileName: c:\file
Version: 3.01

PlotNumber: 1
TotalPoints: 982
FrIndex: 460
F1Index: 427
F2Index: 498
FaIndex: 513

Transducer Type: 8024-004-A9
Serial Number: 
Date: 09-Aug-2013
Operator: LSP
20-80kHz 
     Time: 10:51:35             
Clf pF:             

Range mS: 0.5               
Aut/Man: Auto               
Shunt pF:               
Shunt uH:               
Step size: 150 Hz               
Rate: Max               
Start: 1.0              
Stop: 150.0             



A---------B-------------C--------------D--------E

0---------0.003695---1.000078---0.2-----12  
0---------0.004018---1.150238---0.2-----12
.
.
.

我对A和C很感兴趣。数据有大约1000个条目。

- Laury93

---

我猜想你想要打开的文件纯粹是文本文件？如果是这样，建议你使用Open()在后台打开它们，而不是在Excel中打开。此外，避免使用Windows()和 .Activate & .Select方法，因为这会减慢代码的速度。最后，避免使用.Copy & .Paste，因为这也会复制格式并占用更多内存，从而导致速度变慢。 - kpark

它们是 .csv 文件，我相信... 表格数据本身并不纯粹是数字，但如果需要的话，它可以是数字。如果不激活，我该怎么做？ - Laury93

目前，Excel正在解析文件，然后将它们输出到工作表上，尽管您看不见它。您需要创建一个函数来自行解析数据。顺便说一下，代码似乎比看起来的要多。open_data是什么？查看此内容：https://dev59.com/tmkv5IYBdhLWcg3wqimS - kpark

open_data是用户窗体的名称。什么是解析函数？抱歉 - 我对VBA还很陌生！ - Laury93

完全没有问题，我所说的解析函数是让您创建自己的算法/代码来从文件中分离数据。因此，我们知道.csv由分号分隔，新记录由“回车”分隔。我们需要创建一种方法来制作我们自己的函数来执行.OpenText w/ many many options，如果您有要读取的文件的通用示例，我可能可以帮助您编写解析函数。 - kpark

我已经添加了一个示例作为编辑。 - Laury93

Answer 1

我使用类似的方法循环遍历文件夹中的Excel文件，并使用ADODB读取内容。

Option Explicit

Private Sub ReadXL_ADODB()
Dim cnn1 As New ADODB.Connection
Dim rst1 As New ADODB.Recordset
Dim arrData() As Variant
Dim arrFields() As Variant
Dim EndofPath As String
Dim fs, f, f1, fc, s, filePath
Dim field As Long
Dim lngCount As Long
Dim filescount As Long
Dim wSheet As Worksheet
Dim lstRow As Long

    Set wSheet = Sheet1 'Set sheet to import data to

    With Application.FileDialog(msoFileDialogOpen)
            .AllowMultiSelect = True
            .Show

        For lngCount = 1 To .SelectedItems.Count
            EndofPath = InStrRev(.SelectedItems(lngCount), "\")
            filePath = Left(.SelectedItems(lngCount), EndofPath)
        Next lngCount

    End With

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(filePath)
    Set fc = f.Files
    filescount = 0

    For Each f1 In fc
        DoEvents
        'Open the connection to Excel then open the recordset
        cnn1.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & CStr(f1) & ";" & _
        "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
        'Imports from sheet named xDatabase and range A:EF
        rst1.Open "SELECT * FROM [xDatabase$A:EF];", cnn1, adOpenStatic, adLockReadOnly

        'If target fields are empty write field names
        If WorksheetFunction.CountA(wSheet.Range("1:1")) = 0 Then
            For field = 0 To rst1.Fields.Count - 1
                wSheet.Range("A1").Offset(0, field).Value = rst1.Fields(field).Name
            Next field
        End If
        arrData = rst1.GetRows

        rst1.Close
        cnn1.Close
        Set rst1 = Nothing
        Set cnn1 = Nothing

        'Transpose array for writing to Excel
        arrData = TransposeDim(arrData)

        lstRow = LastRow(wSheet.Range("A:EF"))
        wSheet.Range("A1").Offset(lstRow, 0).Resize(UBound(arrData, 1) + 1, UBound(arrData, 2) + 1).Value = arrData
        filescount = filescount + 1
        Application.StatusBar = "Imported file " & filescount & " of " & fc.Count
    Next f1

Application.StatusBar = False
End Sub

Function TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)

    Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant

    Xupper = UBound(v, 2)
    Yupper = UBound(v, 1)

    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = v(Y, X)
        Next Y
    Next X

    TransposeDim = tempArray

End Function

Public Function LastRow(ByVal rng As Range) As Long
'The most accurate method to return last used row in a range.
On Error GoTo blankSheetError
    'Identify next blank row
    LastRow = rng.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

    'On Error GoTo 0 'not really needed
    Exit Function

blankSheetError:
    LastRow = 2 'Will produce error if blank sheet so default to row 2 as cannot have row 0
    Resume Next

End Function

- user857521

---

您需要添加对 Microsoft ActiveX Data Objects x.Y Library 的引用。另外，由于您正在导入 CSV 文件，因此需要将扩展属性更改为读取 TXT 文件而不是 Excel - 例如 "Extended Properties=""text; HDR=Yes; FMT=Delimited; IMEX=1;""" 并更改 SQL 语句。 - user857521

是的，我刚才看了一下SQL语句。这可能只限于管理员吗？ - Laury93

SQL只是一种语言，因此不太可能受到限制。只要您可以访问文件夹并能够在Excel上启用宏，那么它就应该可以工作。如果您想要访问数据库，那么是有可能受到限制的，并且可能需要登录凭据，但在这种情况下，SQL被用于阅读文本文件，而不是数据库。 - user857521

Answer 2

我在SQL方面遇到了困难，但我找到了一种改进下面代码效率的方法。感谢你们两位的帮助和建议。

我的新代码如下：

Private Sub CBSearch_Click()

    ChDir "File Path"
    ChDrive "C"

    inputname = Application.GetOpenFilename("data files (*.P_1),*.P_1")

    TBFolderPath.Text = CurDir()

End Sub

获取数据的方式：

Private Sub CBRetrieve_Click()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim Element As Integer
Dim I As Long
Dim StrLen As Integer
Dim Folder As String
Dim A As String
Dim ColRef As Integer
Dim FileToOpen As Variant
Dim myString As String, X, j As Integer, k As Integer

Open_Data.Hide

StrLen = Len(TBFolderPath) + 1
Folder = Mid(TBFolderPath, StrLen - 10, 10)

For Element = 1 To 128
A = Right("000" & Element, 3)
    If Dir(TBFolderPath + "\" + Folder + "-" + A + ".P_1") <> "" Then

        FileToOpen = TBFolderPath & "\" & Folder & "-" & A & ".P_1"

        Reset
        Open FileToOpen For Input As #1
        I = 0
        Do While Not EOF(1)
            Input #1, myString
            If IsNumeric(Mid(myString, 1, 1)) = True And _
                IsNumeric(Mid(myString, 2, 1)) = False Then
            X = Split(myString, vbTab)
            I = I + 1

            Sheet1.Cells(I + 15, (2 * Element) - 1).Value = X(0)
            Sheet1.Cells(I + 15, (2 * Element)).Value = X(2)

            End If
        Loop
        Close #1

    End If
Next Element

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

IsNumeric短语相当混乱，但是我需要修整掉前几行，除了一行是20-80之外全都是文本。

谢谢，

Laura

- Laury93