计算两个或多个空格后的字符位置

我试图返回一个值等于两个或多个空格后的第一个字母的位置。

我有一个工具，可以将可变列长的表格提取到TXT文档中。 我需要将这些表格放入Excel工作表中，而不必为每个表格中的每一列都设置固定的宽度（这是很多编码工作）。 我想根据第一个字符在两个或多个空格后的位置来find更dynamic的方法。

请记住，并非所有行都已完全填充，但第一行将成为获得列宽度的理想select。

举一个例子，文本的行看起来像这样

John Robert Eric Tom

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 

Answer 1

代替您的任何确认，我将假设您的实际数据中实际上存在 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）：

Answer 2

您可以使用以下函数从“标题” 行中获取列长度：

 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, ie: 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 

Answer 3

您可以尝试下面的这个function：

 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 

它将一行作为string值并返回一个string数组（每个元素是行中的一个单元格）。 我的假设是没有一个单元格包含2个连续的空格字符，单元格之间至less有两个空格字符。 （在这里，空格字符只表示通过键盘上的长键input的字符，制表符换行符等等）。

要在VBA中使用正则expression式，您需要以下引用（在VBA编辑器中select“工具”>“引用”），然后检查以下选项：