Код VBA для форматирования всего столбца на одну строку

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