计算两个或多个空格后字符的位置
Counting the position of a character after two or more spaces
我正在尝试 return 一个等于两个或更多空格后第一个字母位置的值。
我有一个工具可以将具有可变列长度的 table 提取到 TXT 文档中。我需要将这些 table 放入 Excel sheet 中，而不必为每个 table 中的每一列设置固定宽度（需要完成大量编码） .我试图根据两个或更多空格后第一个字符的位置找到更动态的东西。
请记住，并非所有行都已填满，但第一行是获得列宽的完美候选者。
举个例子，文本的行看起来像这样
约翰 罗伯特 埃里克 汤姆
10 11 143 43
21 265 56
99 241 76
到目前为止我所做的就是按照下面的代码让它以固定宽度工作
Sub exporttosheet()
Dim fPath As String
fPath = "C:\test.txt"
Const fsoForReading = 1
Const F_LEN_A As Integer = 10
Const F_LEN_B As Integer = 23
Const F_LEN_C As Integer = 7
Const F_LEN_D As Integer = 10
Dim objFSO As Object, objTextStream As Object, txt, f1, f2, f3, f4
Dim start As Integer
Dim fLen As Integer
Dim rw As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
rw = 1
Do Until objTextStream.AtEndOfStream
txt = objTextStream.Readline
f1 = Trim(Left(txt, F_LEN_A))
start = F_LEN_A + 1
f2 = Trim(Mid(txt, start, F_LEN_B))
start = start + F_LEN_B + 1
f3 = Trim(Mid(txt, start, F_LEN_C))
start = start + F_LEN_C + 1
f4 = Trim(Mid(txt, start, F_LEN_D))
With ThisWorkbook.Sheets("data").Cells(rw, 1).Resize(1, 4)
.NumberFormat = "@" 'format cells as text
.Value = Array(f1, f2, f3, f4)
End With
rw = rw + 1
Loop
objTextStream.Close
End Sub
您可以试试下面这个功能：
Public Function InterpretLine(strLine As String) As Variant
Dim rgxCell As RegExp: Set rgxCell = New RegExp
rgxCell.Pattern = "([^ ]+([ ]?[^ ]+)*)"
rgxCell.Global = True
Dim mtcResult As MatchCollection: Set mtcResult = rgxCell.Execute(strLine)
Dim strResult() As String: ReDim strResult(0 To mtcResult.Count - 1)
Dim i As Long: For i = 0 To mtcResult.Count - 1
strResult(i) = mtcResult.Item(i)
Next i
InterpretLine = strResult
End Function
它将一行作为字符串值，returns 一个字符串数组（每个元素都是该行的一个单元格）。我的假设是 none 个单元格包含 2 个连续的 space 个字符，并且单元格之间始终至少有两个 space 个字符。 （这里space字符只表示键盘长键输入的字符，不包括tabs换行等。）
要在 VBA 中使用正则表达式，您需要以下参考（在 VBA 编辑器中选择工具 > 参考），并选中以下选项：
您可以使用以下函数从 "header" 行 中获取列长度：
Function GetF_LENs(txt As Variant, nCols As Long) As Variant
Dim t As Variant
Dim iFLEN As Long
t = Split(WorksheetFunction.Trim(txt), " ")
nCols = UBound(t) + 1 '<--| the number of columns equals the number of found values
ReDim FLENs(1 To nCols - 1) '<--| we need the width of columns till the one before the last column
For iFLEN = 1 To nCols - 1
FLENs(iFLEN) = InStr(txt, t(iFLEN))
Next
GetF_LENs = FLENs
End Function
您可以在代码中利用它，如下所示：
Sub exporttosheet()
Const fsoForReading = 1
Dim fPath As String
fPath = "C:\test.txt"
Dim F_LENs As Variant, txt As Variant
Dim objFSO As Object, objTextStream As Object
Dim rw As Long, nCols As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
txt = objTextStream.Readline '<--| read the first "header" line
F_LENs = GetF_LENs(txt, nCols) '<--| get 'F_LENs' array out of "header" line: it stores the widths of all columns
ReDim values(1 To nCols) '<--| resize the array that will hold each row values accordingly to the number of columns encountered
rw = 1
Do Until objTextStream.AtEndOfStream
ReadValuesAndWriteCells txt, F_LENs, values, nCols, rw
txt = objTextStream.Readline '<--| read the first "header" line
Loop
ReadValuesAndWriteCells txt, F_LENs, values, nCols, rw
objTextStream.Close
End Sub
我要求当前行读取和写入以下子
Sub ReadValuesAndWriteCells(txt As Variant, F_LENs As Variant, values As Variant, nCols As Long, rw As Long)
Dim start As Integer
Dim fLen As Integer
start = 1
For fLen = 1 To nCols - 1 '<--| loop through 'F_LENs' array, i.e.: through current line columns
values(fLen) = Trim(Mid(txt, start, F_LENs(fLen) - start)) '<-- store current line current column value in corresponding 'Values' index
start = F_LENs(fLen)
Next
values(fLen) = Trim(Mid(txt, start)) '<-- store current line last column value
With ThisWorkbook.Sheets("data").Cells(rw, 1).Resize(1, nCols)
.NumberFormat = "@" 'format cells as text
.Value = values '<--| write current line array values
End With
rw = rw + 1
End Sub
代替您的任何确认，我将假设您的实际数据中实际上 是 个 unicode 字符。
Option Explicit
Sub Split_My_Data()
Dim s As Long, str As String, tmp As Variant, varFieldInfo As Variant
ReDim tmp(0 To 0)
With Worksheets("Sheet3")
str = .Cells(1, 1).Value2
s = Application.Max(InStrRev(str, Chr(32)), _
InStrRev(str, ChrW(8194)))
Do While CBool(s)
tmp(UBound(tmp)) = Array(s, 1)
str = Left(str, s)
Do While Right(str, 1) = Chr(32) Or Right(str, 1) = ChrW(8194): str = Left(str, Len(str) - 1): Loop
s = Application.Max(InStrRev(str, Chr(32)), _
InStrRev(str, ChrW(8194)))
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
If Not CBool(s) Then Exit Do
Loop
'make the last (first) fieldinfo element
tmp(UBound(tmp)) = Array(0, 1)
'make room for the reversed fieldinfo
ReDim varFieldInfo(LBound(tmp) To UBound(tmp))
'reverse the fieldinfo array
For s = UBound(tmp) To LBound(tmp) Step -1
varFieldInfo(UBound(tmp) - s) = tmp(s)
Next s
'run TextToColumns with the new array of arrays for FieldInfo
.Columns("A:A").TextToColumns Destination:=.Cells(1, "A"), DataType:=xlFixedWidth, FieldInfo:=varFieldInfo
For s = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
With Intersect(.Columns(s), .UsedRange).Cells
'get rid of unicode
.Replace what:=ChrW(8194), replacement:=vbNullString, lookat:=xlPart
'use another texttocolumns as a fast Trim
.TextToColumns Destination:=.Cells(1, "A"), DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1))
'shrink/expand the column
.EntireColumn.AutoFit
.EntireColumn.ColumnWidth = Application.Max(.ColumnWidth, 9)
End With
Next s
End With
End Sub
文本为修剪文本且数字为实数（无 unicode）的结果：
我正在尝试 return 一个等于两个或更多空格后第一个字母位置的值。
我有一个工具可以将具有可变列长度的 table 提取到 TXT 文档中。我需要将这些 table 放入 Excel sheet 中，而不必为每个 table 中的每一列设置固定宽度（需要完成大量编码） .我试图根据两个或更多空格后第一个字符的位置找到更动态的东西。
请记住，并非所有行都已填满，但第一行是获得列宽的完美候选者。
举个例子，文本的行看起来像这样
约翰 罗伯特 埃里克 汤姆
10 11 143 43
21 265 56
99 241 76
到目前为止我所做的就是按照下面的代码让它以固定宽度工作
Sub exporttosheet()
Dim fPath As String
fPath = "C:\test.txt"
Const fsoForReading = 1
Const F_LEN_A As Integer = 10
Const F_LEN_B As Integer = 23
Const F_LEN_C As Integer = 7
Const F_LEN_D As Integer = 10
Dim objFSO As Object, objTextStream As Object, txt, f1, f2, f3, f4
Dim start As Integer
Dim fLen As Integer
Dim rw As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
rw = 1
Do Until objTextStream.AtEndOfStream
txt = objTextStream.Readline
f1 = Trim(Left(txt, F_LEN_A))
start = F_LEN_A + 1
f2 = Trim(Mid(txt, start, F_LEN_B))
start = start + F_LEN_B + 1
f3 = Trim(Mid(txt, start, F_LEN_C))
start = start + F_LEN_C + 1
f4 = Trim(Mid(txt, start, F_LEN_D))
With ThisWorkbook.Sheets("data").Cells(rw, 1).Resize(1, 4)
.NumberFormat = "@" 'format cells as text
.Value = Array(f1, f2, f3, f4)
End With
rw = rw + 1
Loop
objTextStream.Close
End Sub
您可以试试下面这个功能：
Public Function InterpretLine(strLine As String) As Variant
Dim rgxCell As RegExp: Set rgxCell = New RegExp
rgxCell.Pattern = "([^ ]+([ ]?[^ ]+)*)"
rgxCell.Global = True
Dim mtcResult As MatchCollection: Set mtcResult = rgxCell.Execute(strLine)
Dim strResult() As String: ReDim strResult(0 To mtcResult.Count - 1)
Dim i As Long: For i = 0 To mtcResult.Count - 1
strResult(i) = mtcResult.Item(i)
Next i
InterpretLine = strResult
End Function
它将一行作为字符串值，returns 一个字符串数组（每个元素都是该行的一个单元格）。我的假设是 none 个单元格包含 2 个连续的 space 个字符，并且单元格之间始终至少有两个 space 个字符。 （这里space字符只表示键盘长键输入的字符，不包括tabs换行等。）
要在 VBA 中使用正则表达式，您需要以下参考（在 VBA 编辑器中选择工具 > 参考），并选中以下选项：
您可以使用以下函数从 "header" 行 中获取列长度：
Function GetF_LENs(txt As Variant, nCols As Long) As Variant
Dim t As Variant
Dim iFLEN As Long
t = Split(WorksheetFunction.Trim(txt), " ")
nCols = UBound(t) + 1 '<--| the number of columns equals the number of found values
ReDim FLENs(1 To nCols - 1) '<--| we need the width of columns till the one before the last column
For iFLEN = 1 To nCols - 1
FLENs(iFLEN) = InStr(txt, t(iFLEN))
Next
GetF_LENs = FLENs
End Function
您可以在代码中利用它，如下所示：
Sub exporttosheet()
Const fsoForReading = 1
Dim fPath As String
fPath = "C:\test.txt"
Dim F_LENs As Variant, txt As Variant
Dim objFSO As Object, objTextStream As Object
Dim rw As Long, nCols As Long
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
txt = objTextStream.Readline '<--| read the first "header" line
F_LENs = GetF_LENs(txt, nCols) '<--| get 'F_LENs' array out of "header" line: it stores the widths of all columns
ReDim values(1 To nCols) '<--| resize the array that will hold each row values accordingly to the number of columns encountered
rw = 1
Do Until objTextStream.AtEndOfStream
ReadValuesAndWriteCells txt, F_LENs, values, nCols, rw
txt = objTextStream.Readline '<--| read the first "header" line
Loop
ReadValuesAndWriteCells txt, F_LENs, values, nCols, rw
objTextStream.Close
End Sub
我要求当前行读取和写入以下子
Sub ReadValuesAndWriteCells(txt As Variant, F_LENs As Variant, values As Variant, nCols As Long, rw As Long)
Dim start As Integer
Dim fLen As Integer
start = 1
For fLen = 1 To nCols - 1 '<--| loop through 'F_LENs' array, i.e.: through current line columns
values(fLen) = Trim(Mid(txt, start, F_LENs(fLen) - start)) '<-- store current line current column value in corresponding 'Values' index
start = F_LENs(fLen)
Next
values(fLen) = Trim(Mid(txt, start)) '<-- store current line last column value
With ThisWorkbook.Sheets("data").Cells(rw, 1).Resize(1, nCols)
.NumberFormat = "@" 'format cells as text
.Value = values '<--| write current line array values
End With
rw = rw + 1
End Sub
代替您的任何确认，我将假设您的实际数据中实际上 是 个 unicode 字符。
Option Explicit
Sub Split_My_Data()
Dim s As Long, str As String, tmp As Variant, varFieldInfo As Variant
ReDim tmp(0 To 0)
With Worksheets("Sheet3")
str = .Cells(1, 1).Value2
s = Application.Max(InStrRev(str, Chr(32)), _
InStrRev(str, ChrW(8194)))
Do While CBool(s)
tmp(UBound(tmp)) = Array(s, 1)
str = Left(str, s)
Do While Right(str, 1) = Chr(32) Or Right(str, 1) = ChrW(8194): str = Left(str, Len(str) - 1): Loop
s = Application.Max(InStrRev(str, Chr(32)), _
InStrRev(str, ChrW(8194)))
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
If Not CBool(s) Then Exit Do
Loop
'make the last (first) fieldinfo element
tmp(UBound(tmp)) = Array(0, 1)
'make room for the reversed fieldinfo
ReDim varFieldInfo(LBound(tmp) To UBound(tmp))
'reverse the fieldinfo array
For s = UBound(tmp) To LBound(tmp) Step -1
varFieldInfo(UBound(tmp) - s) = tmp(s)
Next s
'run TextToColumns with the new array of arrays for FieldInfo
.Columns("A:A").TextToColumns Destination:=.Cells(1, "A"), DataType:=xlFixedWidth, FieldInfo:=varFieldInfo
For s = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
With Intersect(.Columns(s), .UsedRange).Cells
'get rid of unicode
.Replace what:=ChrW(8194), replacement:=vbNullString, lookat:=xlPart
'use another texttocolumns as a fast Trim
.TextToColumns Destination:=.Cells(1, "A"), DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1))
'shrink/expand the column
.EntireColumn.AutoFit
.EntireColumn.ColumnWidth = Application.Max(.ColumnWidth, 9)
End With
Next s
End With
End Sub
文本为修剪文本且数字为实数（无 unicode）的结果：