如何在不打开VBA的情况下从Excel工作簿检索数据？
我有一个文件夹，可以由用户select，将包含128个文件。 在我的代码中，我打开每个文档并将相关数据复制到我的主工作簿。 所有这些都是通过用户窗体来控制的。 我的问题是完成这个过程所花费的时间（大约50秒） – 当然，我可以做到这一点，而无需打开文件？
此代码用于select要在其中进行search的目录：
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感兴趣的地方有数据。
我使用类似于此的循环浏览文件夹中的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
我努力与SQL，但我find了一种方法来提高下面的代码的效率。 谢谢你们两位的帮助和build议。
我的新代码如下：
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。
干杯，
劳拉