VBA 读写文本文件实现团队信息简单高效

Private Sub CommandButton1_Click()

'遍历当前目录所有文本文件
'按行读取文本文件
Application.ScreenUpdating = False
'若不含模板文件，则自动调用创建模板的过程
If Len(Dir(ThisWorkbook.Path & "\" & "Model.txt")) = 0 Then
CommandButton2_Click
Else
get_current_path_all_files
Dim arr() As String
Dim n As Long
n = 1

Dim arr_temp_get_title As Variant

'打印标题
arr_temp_get_title = input_title(Cells(2, 1).Value2)
On Error GoTo Err_Non_File
For x = 1 To UBound(arr_temp_get_title)
Cells(1, x + 1) = arr_temp_get_title(x)
Next


For i = 2 To 100
If Cells(i, "A") <> "" Then
n = n + 1
ReDim Preserve arr(2 To n)
arr(n) = Cells(n, "A")


'打印数据
Dim arr_temp_get As Variant
arr_temp_get = input_text(arr(n))
Dim m As Integer
For m = 1 To UBound(arr_temp_get)
Cells(n, m + 1) = arr_temp_get(m)
Debug.Print arr_temp_get(m)
Next
End If

Next

'遍历当前目录所有文本文件
MsgBox "已更新所有信息！"
End If
'在正常程序末尾添加Exit Sub,Exit Sub之后添加错误标签和代码，防止未发生错误，错误程序也执行
Exit Sub
Err_Non_File:
MsgBox "未找到文件，请检查！"
End Sub

'输出当前目录下所有文本文件，打印到excel第一列，从第二行开始
Function get_current_path_all_files()
Application.ScreenUpdating = False
Cells(1, 1) = "文件目录"
'正则过滤器

Dim objRegEx As Object
Set objRegEx = CreateObject("vbscript.regexp")
'过滤规则
objRegEx.Pattern = "(.*?).txt"
objRegEx.Global = True

'正则过滤器

'If Cells(5, "B").Value = "ON" Then
Dim filename As String
Dim i As Integer
i = 2
filename = Dir((ThisWorkbook.Path & "\"))
Do While filename <> ""
If filename <> "Model.txt" And objRegEx.Test(filename) = True Then
Sheets(1).Cells(i, 1).Value = filename
i = i + 1
'MsgBox (filename + "读取成功")
End If
filename = Dir
Loop
'Cells(7, "B").Value = "ON"
Debug.Print "已加载所有目录！"
'Else:
'MsgBox "按钮不可用请先解锁！"
'End If
End Function
'获取单个文本文件每行分割后的值组成的数组，用于打印内容
Function input_text(file_path As String) As Variant

Dim arr_result() As String
Dim n As Integer
'分割字符串
Dim sep As String
sep = "|"
Open ThisWorkbook.Path & "\" & file_path For Input As #1
Do While Not EOF(1)
Line Input #1, strTemp
n = n + 1
ReDim Preserve arr_result(1 To n)
arr_result(n) = Split(strTemp, sep)(1)
Loop
input_text = arr_result
Close #1
End Function
'获取单个文本文件每行分割后的键组成的数组，用于打印标题
Function input_title(file_path As String) As Variant

Dim arr_result() As String
Dim n As Integer
'分割字符串
Dim sep As String
sep = "|"
On Error GoTo MyErr1
Open ThisWorkbook.Path & "\" & file_path For Input As #1
Do While Not EOF(1)
Line Input #1, strTemp
n = n + 1
ReDim Preserve arr_result(1 To n)
arr_result(n) = Split(strTemp, sep)(0)
Loop
input_title = arr_result
Close #1
MyErr1:
End Function

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False

'创建文本文件模板
'定义上限列
Dim upperlimit As Integer
'定义分割字符串
Dim sep As String
'定义一个变量存储最后一个不为空的列数，后面限制不超过上限upperlimit
Dim last_not_null_cell_column As Integer
Dim gPath As String
Dim sFile As Object, Fso As Object
gPath = ThisWorkbook.Path
'最大支持列数
upperlimit = 100
sep = "|"
Set Fso = CreateObject("Scripting.FileSystemObject")
' 文件路径，是否可复写，True可复写，否或忽略则不可复写，文本编码格式，省略或False未ASCII码，否则unicode
Set sFile = Fso.CreateTextFile(gPath & "\Model.txt", True, False)
'判断最后一个不为空的单元格的列数
For n = 2 To upperlimit

If Cells(1, n).Value2 <> "" Then
last_not_null_cell_column = n
End If

Next
'判断最后一个不为空的单元格的列数
'按行将单元格内容写入文本文件对象，加上分隔符做成模板
For n = 2 To last_not_null_cell_column
sFile.WriteLine (Cells(1, n).Value2 & sep)
Next
'sFile.WriteLine ("CreateTextFile Test")
sFile.Close
Set sFile = Nothing
Set Fso = Nothing
MsgBox "模板已创建成功，在当前目录下，请查看Model.txt" & vbCrLf & ThisWorkbook.Path & "\" & "Model.txt"
End Sub