如何在不打开 VBA 的情况下从 Excel 工作簿中检索数据？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/18359286/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How do I retrieve data from an Excel Workbook without opening in VBA?
提问by Laury93
I have a folder, which is selectable by a user, which will contain 128 files. In my code, I open each document and copy the relevant data to my main workbook. All this is controlled through a userform. My problem is the time it takes to complete this process (about 50 seconds) - surely I can do it without opening the document at all?
我有一个可供用户选择的文件夹，其中包含 128 个文件。在我的代码中，我打开每个文档并将相关数据复制到我的主工作簿。所有这些都是通过用户表单控制的。我的问题是完成此过程所需的时间（大约 50 秒） - 我当然可以在不打开文档的情况下完成它吗？
This code is used to select the directory to search in:
此代码用于选择要搜索的目录：
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
This Retrieves the files:
这将检索文件：
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 is the contents of a textbox in the userform, and is the location of the files.
TBFolderPath 是用户表单中文本框的内容，也是文件的位置。
Sorry my code is so messy!
抱歉我的代码太乱了！
EDIT: An example of the data is:
编辑：数据的一个例子是：
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
.
.
.
Where I am interested in A and C. Data has about 1000 entries.
我对 A 和 C 感兴趣的地方。数据大约有 1000 个条目。
采纳答案by user3357963
I use something similar to this to cycle through Excel files in a folder and use ADODB to read the contents.
我使用类似的东西来循环浏览文件夹中的 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
回答by Laury93
I struggled with SQL, but I found a way to improve the efficiency of the code below. Thank you, both of you for your help and suggestions.
我在 SQL 上苦苦挣扎，但我找到了一种提高下面代码效率的方法。谢谢两位的帮助和建议。
My new code is as follows:
我的新代码如下：
Private Sub CBSearch_Click()
ChDir "File Path"
ChDrive "C"
inputname = Application.GetOpenFilename("data files (*.P_1),*.P_1")
TBFolderPath.Text = CurDir()
End Sub
And for retrieveing the data:
并用于检索数据：
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
The IsNumeric phrases are quite messy, but I needed to trim the first few lines off, all but one being text, and that one being 20-80.
IsNumeric 短语相当混乱，但我需要剪掉前几行，除了一行是文本，另一行是 20-80。
Cheers,
干杯，
Laura
劳拉
