大家好，我是你们的Excel小助手，今天要给大家分享一个超酷的小技巧，绝对能让你成为办公室里的最靓的仔！
大家都知道Excel表格复制成txt后无法带边框，然后发现复制粘贴总是格式乱七八糟。别着急，今天我就要教你一个神奇的VBA技巧，一键导出带有管道符的TXT文件，格式整整齐齐，再也不怕txt显示不了表格啦！
代码示例
下面是实现这一功能的VBA代码，你只需要将这段代码插入到Excel的VBA编辑器中，然后运行它，即可将选中的表格区域导出为带有制表符的TXT文件。
'======================================================
'将选中区域导出为带有制表符的TXT文件，注意需要使用等宽字体（如新宋体）才能正确显示
'参数：selection，可通过给Rng重新赋值来修改要导出的区域
'生成的TXT文件路径和名称与当前文档一样
'======================================================
Public StrLength As Integer '每个单元格一行所容纳的最大字符长度
Public rng As Range '要导出的单元格区域
Sub Table()
Dim arr() As Variant, brr() As Variant
Dim row As Integer, Col As Integer
Dim i As Integer, j As Integer, k As Integer
Dim Max As Integer
Dim cell As Range, cell2 As Range
Dim StartRow As Integer, EndRow As Integer
Dim StartCol As Integer, EndCol As Integer
Dim L As Integer
Dim n As Integer
Dim width As Integer
Dim crr As Variant
Dim ColWidth() As Variant '导出后所有列的字节数
StrLength = 16 '字符长度限制为16，即32个字节【此数值限制最大列宽】
Set rng = Selection '设置导出的区域，默认是选中的区域
If rng.count <= 1 Then MsgBox "不支持独立单元格的导出！": Exit Sub '错误提示
'设置带制表符的数组的大小
arr = rng.Value
row = UBound(arr, 1) * 2 + 1
Col = UBound(arr, 2) * 2 + 1
ReDim arr(1 To row, 1 To Col)
'生成四角框
arr(1, 1) = "┌"
arr(1, Col) = "┐"
arr(row, 1) = "└"
arr(row, Col) = "┘"
'生成内框和内部数据
For i = 2 To row - 1
For j = 2 To Col - 1
Select Case i Mod 2
Case 1
If j Mod 2 = 1 Then arr(i, j) = "┼"
If j Mod 2 = 0 Then arr(i, j) = "─"
Case 0
If j Mod 2 = 1 Then arr(i, j) = "│"
If j Mod 2 = 0 Then arr(i, j) = rng.Cells(i / 2, j / 2)
End Select
Next j
Next i
'生成外框
For i = 2 To row - 1
If i Mod 2 = 0 Then
arr(i, 1) = "│"
arr(i, Col) = "│"
Else
arr(i, 1) = "├"
arr(i, Col) = "┤"
End If
Next i
For j = 2 To Col - 1
If j Mod 2 = 0 Then
arr(1, j) = "─"
arr(row, j) = "─"
Else
arr(1, j) = "┬"
arr(row, j) = "┴"
End If
Next j
'求列宽
ReDim ColWidth(1 To Col)
'单元格从右向左倒序，便于计算合并单元格的字节数
For j = Col - 1 To 2 Step -2
Max = 0
For i = 2 To row - 1 Step 2 '数据所在行
With rng.Cells(i / 2, j / 2)
Select Case .MergeCells
Case False '不属于合并单元格
L = LenB(StrConv(arr(i, j), vbFromUnicode))
Case True '属于合并单元格
If .MergeArea.Column = .Column Then
width = 0
brr = .MergeArea.Value
If UBound(brr, 2) > 1 Then '列数>1
For k = 2 To (UBound(brr, 2) - 1) * 2
width = width + ColWidth(j + k)
Next k
'这个值应该是合并单元格上方的非合并单元格的字节数
L = CellWidth(i, j, rng, ColWidth) - 2 * (UBound(brr, 2) - 1) - width
Else '列数=1
L = CellWidth(i, j, rng, ColWidth)
End If
Else
L = 0
End If
End Select
End With
If Max < L Then Max = L
Next i
If Max Mod 2 = 1 Then Max = Max + 1 '字节数必须是偶数
ColWidth(j) = Application.Min(Max, StrLength * 2)
If Max < StrLength * 2 Then
ColWidth(j) = Max
Else
ColWidth(j) = StrLength * 2
End If
Next j
'整理格式
For j = 2 To Col - 1 Step 2 '遍历字符所在列
' If j Mod 2 = 0 Then '字符所在列
For i = 1 To row
L = LenB(StrConv(arr(i, j), vbFromUnicode)) '字节数
Select Case i Mod 2
Case 0 '如果是偶数行，即数据所在行
Set cell = rng.Cells(i / 2, j / 2)
If Not cell.MergeCells Then
If ColWidth(j) > L Then _
arr(i, j) = arr(i, j) & String(ColWidth(j) - L, " ")
ElseIf cell.MergeArea.Column = cell.Column Then
If CellWidth(i, j, rng, ColWidth) > L Then _
arr(i, j) = arr(i, j) & String(CellWidth(i, j, rng, ColWidth()) - L, " ")
ElseIf cell.MergeArea.Column <> cell.Column Then
arr(i, j) = ""
End If
Case 1 '如果是奇数行，即制表符行
' L = LenB(StrConv(arr(i, j), vbFromUnicode)) '字节数
If ColWidth(j) >= L Then
arr(i, j) = arr(i, j) & String((ColWidth(j) - L) / 2, "─")
Else
arr(i, j) = "" '如果制表符字节数比max大则代表这一列的单元格内容都为空，则删除制表符
End If
End Select
Next i
' End If
Next j
'处理合并单元格
For Each cell In rng
If cell.MergeCells Then
'利用数组来找到合并单元格的起始位置和结束位置
brr = cell.MergeArea.Value
StartRow = cell.MergeArea.row - rng.row + 1
StartCol = cell.MergeArea.Column - rng.Column + 1
EndRow = StartRow + UBound(brr, 1)
EndCol = StartCol + UBound(brr, 2)
'调用处理合并单元格子函数
merge arr, StartRow, EndRow, StartCol, EndCol
End If
Next
'处理换行符
For Each cell In rng
n = Len(cell) - Len(Replace(cell, Chr(10), ""))
If n > 0 Then
i = (cell.row - rng.row + 1) * 2
j = (cell.Column - rng.Column + 1) * 2
width = CellWidth(i, j, rng, ColWidth) / 2
crr = Split(cell.Value, Chr(10))
For k = 0 To n - 1
L = Len(crr(k))
Select Case L
Case Is <= width
crr(k) = crr(k) & String(width - L, " ")
Case Is > width
crr(k) = crr(k) & String(width - (L Mod width), " ")
End Select
Next k
arr(i, j) = Join(crr, "")
' Debug.Print arr(i, j), LenB(StrConv(arr(i, j), vbFromUnicode))
[a30] = arr(i, j)
End If
Next
'处理换行
' 从倒数第2行开始遍历所有数据所在行，避免插入新行后对arr中未整理的行号造成影响
i = UBound(arr, 1)
Do While i > 1
Max = 0
For j = 2 To Col - 1 Step 2 '数据所在列
L = LenB(StrConv(arr(i, j), vbFromUnicode))
width = CellWidth(i, j, rng, ColWidth)
If L > width And width <> 0 Then
n = Int(Len(arr(i, j)) / (width / 2)) '换行数
If Max < n Then Max = n
End If
Next j
If Max > 0 Then InsertLine arr, i, Max '插入行
i = i - 1 '跳至下一个数据行
Loop
SaveTxt arr
End Sub
'======================================================
'将表格中的某个区域导出TXT文档
'参数：数组变量
'生成的TXT文件路径和名称与当前文档一样
'======================================================
Sub SaveTxt(ByVal arr As Variant)
Dim path As String
Dim i As Integer, j As Integer
Dim Str As String
path = ThisWorkbook.path & "\" & Left(ThisWorkbook.Name, _
Application.Find(".", ThisWorkbook.Name) - 1) & ".txt"
Open path For Output As #1
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
Str = Str & arr(i, j)
Next j
Print #1, Str
Str = ""
Next i
Close #1
End Sub
'处理合并单元格的制表符格式
Sub merge(ByRef arr() As Variant, ByVal stRow As Integer, _
ByVal edRow As Integer, ByVal stCol As Integer, ByVal edCol As Integer)
Dim Row1 As Integer
Dim Row2 As Integer
Dim Col1 As Integer
Dim Col2 As Integer
Dim i As Integer, j As Integer
'数组中的位置
Row1 = stRow * 2 - 1
Col1 = stCol * 2 - 1
Row2 = edRow * 2 - 1
Col2 = edCol * 2 - 1
'处理内部线框
For i = Row1 + 1 To Row2 - 1
For j = Col1 + 1 To Col2 - 1
If i Mod 2 <> 0 Then
arr(i, j) = String(LenB(StrConv(arr(i, j), vbFromUnicode)), " ")
ElseIf j Mod 2 <> 0 Then
arr(i, j) = ""
End If
Next j
Next i
'处理上下框线
For i = Col1 + 1 To Col2 - 1
arr(Row1, i) = Replace(arr(Row1, i), "┼", "┴")
arr(Row1, i) = Replace(arr(Row1, i), "┬", "─")
arr(Row2, i) = Replace(arr(Row2, i), "┼", "┬")
arr(Row2, i) = Replace(arr(Row2, i), "┴", "─")
Next i
'处理左右框线
For i = Row1 + 1 To Row2 - 1
arr(i, Col1) = Replace(arr(i, Col1), "┼", "┤")
arr(i, Col1) = Replace(arr(i, Col1), "├", "│")
arr(i, Col2) = Replace(arr(i, Col2), "┼", "├")
arr(i, Col2) = Replace(arr(i, Col2), "┤", "│")
Next i
End Sub
Sub InsertLine(ByRef arr() As Variant, ByVal InsRow As Integer, ByVal n As Integer)
Dim i As Integer, j As Integer
Dim brr() As Variant
Dim Length As Integer, L As Integer
Dim row As Integer, Col As Integer
'插入后表格的行数和列数
row = UBound(arr, 1) + n
Col = UBound(arr, 2)
ReDim brr(1 To row, 1 To Col)
'把arr的内容逐个复制到brr中，同时插入换行的内容
For i = 1 To row
For j = 1 To Col
Select Case i
'复制插入之前的行
Case Is <= InsRow
brr(i, j) = arr(i, j)
'处理插入行的内容
Case Is <= InsRow + n
Select Case j Mod 2
Case Is = 1 '奇数列即制表符列，直接复制上一行的内容
brr(i, j) = arr(InsRow, j)
Case Is = 0 '偶数列即数据所在列，按行号截取字符串内容
Length = LenB(StrConv(arr(InsRow, j), vbFromUnicode)) '字符串字节数
L = CellWidth(InsRow, j, rng, ColWidth) / 2
'单元格字节数/2
If Length <= L * 2 Then
brr(i, j) = String(Length, " ")
Else
brr(i, j) = Mid(arr(InsRow, j), L * (i - InsRow) + 1, L)
' Debug.Print arr(InsRow, j),LenB(StrConv(arr(InsRow, j), vbFromUnicode))
'使插入的单元格字节长度符合要求
Length = LenB(StrConv(brr(i, j), vbFromUnicode))
If Length < L * 2 Then brr(i, j) = brr(i, j) & String(L * 2 - Length, " ")
'处理原单元格的字符内容
brr(InsRow, j) = Left(arr(InsRow, j), L)
Length = LenB(StrConv(brr(InsRow, j), vbFromUnicode))
If Length < L * 2 Then brr(InsRow, j) = brr(InsRow, j) & _
String(L * 2 - Length, " ")
End If
End Select
'复制插入行之后的内容
Case Else
brr(i, j) = arr(i - n, j)
End Select
Next j
Next i
'将brr的值赋给arr
ReDim arr(1 To row, 1 To Col)
arr = brr
End Sub
'Function IsFirstCol(ByVal i As Integer, ByVal j As Integer, Rng As Range)
' With Rng.Cells(i / 2, j / 2)
' If .MergeArea.Column = .Column Then
' IsFirstCol = True
' Else
' IsFirstCol = False
' End If
' End With
'End Function
'单元格宽度
Function CellWidth(ByVal i As Integer, ByVal j As Integer, rng As Range, ColWidth As Variant)
Dim width As Integer
Dim brr() As Variant
Dim L As Integer
Dim k As Integer
Dim strL As Integer
With rng.Cells(i / 2, j / 2)
strL = LenB(StrConv(.Value, vbFromUnicode))
If .MergeCells Then
If .MergeArea.Column = .Column Then
width = 0
brr = .MergeArea.Value
If UBound(brr, 2) > 1 Then
For k = 2 To (UBound(brr, 2) - 1) * 2
width = width + ColWidth(j + k)
Next k
L = 2 * (UBound(brr, 2) - 1) + width + ColWidth(j)
If L < strL Then L = Application.Max(StrLength * 2, L)
Else
L = Application.Max(ColWidth(j), Application.Min(StrLength * 2, strL))
End If
Else
L = 0
End If
Else
L = ColWidth(j)
End If
End With
If i Mod 2 = 1 Then L = ColWidth(j)
If L Mod 2 = 1 Then L = L + 1
CellWidth = L
End Function
一点小提示
在导出之前，记得选中你想要导出的表格区域哦！
导出的txt文件字体需要选择等宽字体（如新宋体），格式才能对齐哟！
嘿，是不是觉得这个小魔法很有趣？以后再也不用为分享Excel表格而烦恼了，一键导出，整整齐齐，妈妈再也不用担心我分享数据啦！如果你还有其他有趣的VBA小技巧，快快留言分享给大家吧！
发表回复