我有一个文件夹，可由用户选择，其中包含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是userform中文本框的内容，是文件的位置。
抱歉我的代码太乱了！
编辑： 数据的一个例子是：
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个条目。
答案 0 :(得分：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
答案 1 :(得分：0)
我在使用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。
干杯，
劳拉