3

我有一个用户可选择的文件夹，其中包含 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 个条目。

4

2 回答 2

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
于 2013-08-21T14:19:16.023 回答
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。

干杯，

劳拉

于 2013-08-22T13:26:23.333 回答