3

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

我有一个工具可以将具有可变列长度的表提取到 TXT 文档中。我需要将这些表放入 Excel 工作表中，而不必为每个表中的每一列设置固定宽度（这是要完成的大量编码）。我试图根据两个或多个空格后第一个字符的位置找到更动态的方法。

请记住，并非所有行都已完全填充，但第一行将成为获得列宽的完美候选者。

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

约翰·罗伯特·埃里克·汤姆

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
4

3 回答 3

3

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

在此处输入图像描述

于 2017-04-01T16:55:56.857 回答
1

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

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
于 2017-04-01T16:04:06.797 回答
0

您可以在下面尝试此功能：

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

它将一行作为字符串值并返回一个字符串数组（每个元素都是行中的一个单元格）。我的假设是没有一个单元格包含 2 个连续的空格字符，并且单元格之间总是至少有两个空格字符。（这里的空格字符仅表示通过键盘上的长键输入的字符，不包括制表符换行符等。）

要在 VBA 中使用 Regex，您需要以下参考（在 VBA 编辑器中选择工具 > 参考），并选中以下选项：

在此处输入图像描述

于 2017-04-01T13:49:27.697 回答