用于将整列格式化为一行的VBA代码

问题描述 投票：0回答：1

我正在创建一个将在我的excel文件的后台运行的VBA程序。此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'
excel vba
1个回答
0
投票

我想到了。这是更新的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
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.