Question

我正在创建一个VBA程序，该程序将在我的excel文件的后台运行。此VBA程序将从文本文件的文件夹中读取字段。我已经获取了需要阅读的字段，但是格式方面遇到了麻烦。读出的每个值都放在excel文件的下一行中，但是将其放在正确的行中，因此，我需要弄清楚一旦读完所有内容后如何将整列向上移动一行。添加了我的整个程序，这是在Java标头（它是VBA代码）下输入时最容易看到的程序。我省略了存储我的值的cLines类。我认为程序中写入工作表的部分是我们必须插入格式的地方。

    'Main Module

Option Explicit
'NOTE:  Set reference to Microsoft Scripting Runtime

Sub FindInFile()
    Dim sBaseFolder As String, sFindText As String, sFindTracNum As String, sFindTrailNum As String, sFindRemarks As String
    Dim FD As FileDialog
    Dim FSO As FileSystemObject, FIs As Files, FI As File, FO As Folder
    Dim TS As TextStream
    Dim colL As Collection, TracNum As Collection, TrailNum As Collection, Remarks As Collection, cL As cLines
    Dim S As String, strPath As String
    Dim I As Long
    Dim R As Range
    Dim wsRes As Worksheet, rRes As Range, vRes() As Variant

'Set results worksheet and range
Set wsRes = Worksheets("Sheet1")
Set rRes = wsRes.Cells(1, 1)

sFindText = "Driver Name:"
sFindTracNum = "Tractor #:"
sFindTrailNum = "Trailer #:"
sFindRemarks = "Remarks:"

'Specify the folder
strPath = "C:\test\Excel Test"



'Get the Text files in the folder
Set FSO = New FileSystemObject
Set FO = FSO.GetFolder(strPath)
Set FIs = FO.Files


'Collect the information
Set colL = New Collection
Set TracNum = New Collection
Set TrailNum = New Collection
Set Remarks = New Collection

For Each FI In FIs
With FI
    If .Name Like "*.txt" Then
        I = 0
        Set TS = FSO.OpenTextFile(strPath & "\" & .Name, ForReading)
        Do Until TS.AtEndOfStream
            S = TS.ReadLine
            I = I + 1
            Set cL = New cLines

            If InStr(1, S, sFindText, vbTextCompare) > 0 Then

                With cL
                    .LineText = S
                End With

                colL.Add cL

            ElseIf InStr(1, S, sFindTrailNum, vbTextCompare) > 0 Then

                With cL
                    .TrailNum = S
                End With


                colL.Add cL

            End If
        Loop
    End If
End With
Next FI

'Write the collection to a VBA array
ReDim vRes(0 To colL.Count, 1 To 6)

'Column Headers

vRes(0, 1) = "Driver Name"
vRes(0, 2) = "Tractor#"
vRes(0, 3) = "Trailer#"
vRes(0, 4) = "Remarks"
vRes(0, 5) = "Next" & vbLf & "Plan"
vRes(0, 6) = "Status" & vbLf & "of" & vbLf & "Repairs"


For I = 1 To colL.Count
With colL(I)
    vRes(I, 1) = .LineText
    vRes(I, 2) = .TracNum
    vRes(I, 3) = .TrailNum
    vRes(I, 4) = .Remarks
End With
Next I

'Write to the worksheet
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    With .Columns(3)
        '.EntireRow.Cut
        '.Offset(-1, 0).EntireRow.Insert shift:=xlDown
    End With
    .EntireColumn.ColumnWidth = 45
    With .EntireRow
        .WrapText = True
        .VerticalAlignment = xlCenter
        .AutoFit
    End With
    .EntireColumn.AutoFit

    'Remove the FindWord
    For Each R In rRes.Offset(1).Resize(rRes.Rows.Count - 1).Columns(1).Cells
        I = 1
        Do
            I = InStr(I, R.Text, sFindText, vbTextCompare)
            With R.Characters(I, Len(sFindText))
                .Delete

            End With
            I = InStr(I + 1, R.Text, sFindText, vbTextCompare)


        Loop Until I = 0
    Next R

    For Each R In rRes.Offset(1).Resize(rRes.Rows.Count - 1).Columns(3).Cells
        I = 1
        Do
            I = InStr(I, R.Text, sFindTrailNum, vbTextCompare)
            With R.Characters(I, Len(sFindTrailNum))
                .Delete

            End With
            I = InStr(I + 1, R.Text, sFindTrailNum, vbTextCompare)


        Loop Until I = 0
    Next R

End With
Application.ScreenUpdating = True

End Sub'

Answer 1

我知道了。这是更新的VBA代码：

Option Explicit


'Private Sub Workbook_Open()
'Call FindInFile
'End Sub

'NOTE:  Set reference to Microsoft Scripting Runtime
Sub FindInFile()

 '   Application.OnTime Now + TimeValue("00:01"), "FindInFile"
    
    Dim sBaseFolder As String, sFindText As String, sFindTracNum As String
    Dim sFindTrailNum As String, sFindRemarks As String, sFindDefect As String
    Dim FD As FileDialog
    Dim FSO As FileSystemObject, FIs As Files, FI As File, FO As Folder
    Dim TS As TextStream
    Dim colL As Collection, TracNum As Collection, TrailNum As Collection
    Dim Remarks As Collection, Defect As Collection, cL As cLines
    Dim S As String, C As String, strPath As String
    Dim I As Long, T As Long, G As Long, H As Long
    Dim R As Range
    Dim wsRes As Worksheet, rRes As Range, vRes() As Variant
    
'Set results worksheet and range
Set wsRes = Worksheets("Sheet1")
Set rRes = wsRes.Cells(1, 1)
   
'Set text you will search for in files
sFindText = "Driver Name:"
sFindTracNum = "Tractor #:"
sFindTrailNum = "Trailer #:"
sFindRemarks = "Remarks:"
sFindDefect = "Defect Found?: No"

'Specify the folder
strPath = "C:\test\Excel Test"



'Get the Text files in the folder
Set FSO = New FileSystemObject
Set FO = FSO.GetFolder(strPath)
Set FIs = FO.Files


'Collect the information
Set colL = New Collection
Set TracNum = New Collection
Set TrailNum = New Collection
Set Remarks = New Collection
Set Defect = New Collection

'Get each field out of the text files
For Each FI In FIs
With FI
    If .Name Like "*.txt" Then
        I = 0
        Set TS = FSO.OpenTextFile(strPath & "\" & .Name, ForReading)
        Do Until TS.AtEndOfStream
            S = TS.ReadLine
            I = I + 1
            Set cL = New cLines
            
            If InStr(1, S, sFindDefect, vbTextCompare) > 0 Then
                                
                                
                'If (S = "Defect Found?: Yes") Then
                'End If
            End If
            If InStr(1, S, sFindText, vbTextCompare) > 0 Then
                
                With cL
                    .LineText = S
                End With

                colL.Add cL
                
            ElseIf InStr(1, S, sFindTrailNum, vbTextCompare) > 0 Then
                
                With cL
                    .TrailNum = S
                End With

                TrailNum.Add cL
                       
            ElseIf InStr(1, S, sFindRemarks, vbTextCompare) > 0 Then
                
                With cL
                    .Remarks = S
                End With

                Remarks.Add cL
                                       

            End If
        Loop
    End If
End With
Next FI

'Write the collection to a VBA array
ReDim vRes(0 To colL.Count, 1 To 5)

'Column Headers

vRes(0, 1) = "Driver Name"
vRes(0, 2) = "Tractor#"
vRes(0, 3) = "Trailer#"
vRes(0, 4) = "Remarks"
vRes(0, 5) = "Defect?"
'vRes(0, 6) = "Status" & vbLf & "of" & vbLf & "Repairs"

'Get all of the information on the correct line
For I = 1 To colL.Count
With colL(I)
    vRes(I, 1) = .LineText
End With
Next I

For T = 1 To TrailNum.Count
With TrailNum(T)
    vRes(T, 3) = .TrailNum
End With
Next T

For G = 1 To Remarks.Count
With Remarks(G)
    vRes(G, 4) = .Remarks
End With
Next G

For H = 1 To Defect.Count
With Defect(H)
    vRes(H, 5) = .Defect
End With
Next H


'Write to the worksheet
Application.ScreenUpdating = False
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .RowHeight = 36
    End With
    .EntireColumn.ColumnWidth = 45
    With .EntireRow
        .WrapText = True
        .VerticalAlignment = xlCenter
        '.AutoFit
    End With
    .EntireColumn.AutoFit

    'Remove the word that is found
    For Each R In rRes.Offset(1).Resize(rRes.Rows.Count - 1).Columns(1).Cells
        I = 1
        Do
            I = InStr(I, R.Text, sFindText, vbTextCompare)
            With R.Characters(I, Len(sFindText))
                .Delete
            End With
            I = InStr(I + 1, R.Text, sFindText, vbTextCompare)
            
        Loop Until I = 0
    Next R
    
    For Each R In rRes.Offset(1).Resize(rRes.Rows.Count - 1).Columns(3).Cells
        I = 1
        Do
            I = InStr(I, R.Text, sFindTrailNum, vbTextCompare)
            With R.Characters(I, Len(sFindTrailNum))
                .Delete
            End With
            I = InStr(I + 1, R.Text, sFindTrailNum, vbTextCompare)
            
        Loop Until I = 0
    Next R
    
        For Each R In rRes.Offset(1).Resize(rRes.Rows.Count - 1).Columns(4).Cells
        I = 1
        Do
            I = InStr(I, R.Text, sFindRemarks, vbTextCompare)
            With R.Characters(I, Len(sFindRemarks))
                .Delete
            End With
            I = InStr(I + 1, R.Text, sFindRemarks, vbTextCompare)
            
        Loop Until I = 0
    Next R

End With
Application.ScreenUpdating = True

End Sub

VBA代码可将整列格式化为一行

1 个答案: