VBA code to format an entire column up one row - excel

Question

I am creating a VBA program that will run in the background of my excel file. This VBA program will read fields in from a folder of text files. I have gotten the fields I need read in, I am just having trouble with the formatting. Every value that is read out is put on the next line in the excel file, but it puts it in the correct row, so I need to figure out how to move a whole column up one row once everything is read in. Below I have added my entire program, which was the easiest to see when entering it under the java header(it is VBA code). I have left out my cLines class where my values get stored. The part in the program that writes to the worksheet is where I believe that we will have to insert the formatting.
'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

I figured it out. Here is the updated VBA code:
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