Question

我将一个字符串压缩到一个单元格中。我需要将字符串的每个部分分隔到它们自己的单元格中，同时从同一行复制数据。

以下是我的示例数据：

        A               |    B                  
Row1 ABC ABD ABE ABF    |  CODE1
Row2 BCA DBA EBA FBA    |  CODE2
Row3 TEA BEF            |  CODE3

结果将是：

 A     B
ABC  CODE1
ABD  CODE1
ABE  CODE1
ABF  CODE1
BCA  CODE2
DBA  CODE2
EBA  CODE2
FBA  CODE2
TEA  CODE3
BEF  CODE3

我有大约2000行，并且实际上需要30年才能使用文本到列函数。所以我想写一个vba宏。我想我正在努力实现这一目标。任何想法或推动正确的方向将不胜感激。在此先感谢您的帮助。

Answer 1

这会起作用，（但是除非你在一个数组中执行它，否则效率很低......但是只有2000行，你甚至不会注意到滞后）

Function SplitThis(Str as String, Delimiter as String, SerialNumber as Long) As String
    SplitThis = Split(Str, Delimiter)(SerialNumber - 1)
End Function

将其用作

= SPLITTHIS("ABC EFG HIJ", " ", 2)

' The result will be ...

"EFG"

如果您需要将它用于分布式应用程序，您仍需要进行大量额外的错误检查等，因为用户可能会输入大于“拆分元素”数量的值或获取分隔符错了，等等。

Answer 2

我喜欢在细胞上迭代这个帖子的问题。

        ' code resides on input sheet
        Sub ParseData()
            Dim wksOut As Worksheet
            Dim iRowOut As Integer
            Dim iRow As Integer
            Dim asData() As String
            Dim i As Integer
            Dim s As String

            Set wksOut = Worksheets("Sheet2")
            iRowOut = 1

            For iRow = 1 To UsedRange.Rows.Count
                asData = Split(Trim(Cells(iRow, 1)), " ")
                For i = 0 To UBound(asData)
                    s = Trim(asData(i))
                    If Len(s) > 0 Then
                        wksOut.Cells(iRowOut, 1) = Cells(iRow, 2)
                        wksOut.Cells(iRowOut, 2) = s
                        iRowOut = iRowOut + 1
                    End If
                Next i
            Next iRow

            MsgBox "done"
        End Sub

Answer 3

假设您的数据位于第一张纸上，则会使用格式化数据填充第二张纸。我还假设数据是统一的，这意味着在数据结束之前每一行都有相同类型的数据。我没有尝试标题行。

Public Sub FixIt()

    Dim fromSheet, toSheet As Excel.Worksheet

    Dim fromRow, toRow, k As Integer

    Dim code As String

    Set fromSheet = Me.Worksheets(1)
    Set toSheet = Me.Worksheets(2)

    ' Ignore first row
    fromRow = 2

    toRow = 1

    Dim outsideArr() As String
    Dim insideArr() As String

    Do While Trim(fromSheet.Cells(fromRow, 1)) <> ""

        ' Split on the pipe
        outsideArr = Split(fromSheet.Cells(fromRow, 1), "|")

        ' Split left of pipe, trimmed, on space
        insideArr = Split(Trim(outsideArr(0)), " ")

        ' Save the code
        code = Trim(outsideArr(UBound(outsideArr)))

        ' Skip first element of inside array
        For k = 1 To UBound(insideArr)
            toSheet.Cells(toRow, 1).Value = insideArr(k)
            toSheet.Cells(toRow, 2).Value = code
            toRow = toRow + 1

        Next k

        fromRow = fromRow + 1

    Loop


End Sub

Answer 4

让我尝试使用 Dictionary ：）

Sub Test()
    Dim r As Range, c As Range
    Dim ws As Worksheet
    Dim k, lrow As Long, i As Long

    Set ws = Sheet1 '~~> change to suit, everything else as is
    Set r = ws.Range("B1", ws.Range("B" & ws.Rows.Count).End(xlUp))

    With CreateObject("Scripting.Dictionary")
        For Each c In r
            If Not .Exists(c.Value) Then
                .Add c.Value, Split(Trim(c.Offset(0, -1).Value))
            End If
        Next
        ws.Range("A:B").ClearContents
        For Each k In .Keys
            lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            If lrow = 1 Then i = 0 Else i = 1
            ws.Range("A" & lrow).Offset(i, 0) _
                .Resize(UBound(.Item(k)) + 1).Value = Application.Transpose(.Item(k))
            ws.Range("A" & lrow).Offset(i, 1).Resize(UBound(.Item(k)) + 1).Value = k
        Next
    End With
End Sub

上面的代码加载 Dictionary 中的所有项目，然后在同一范围内返回它。 HTH。

Answer 5

这是一种使用用户定义类型，集合和数组的方法。我最近一直在使用它并认为它可能适用。一旦你习惯了它，它确实使编写代码变得更容易。

用户定义的类型在类模块中设置。我打电话给＃34; CodeData＆＃34;并给它两个属性 - 代码和数据

我认为您的数据位于A＆amp;列; B从第1行开始;我把结果放在同一个工作表上，但是在D＆amp;列中。 E.如果可以的话，这可以很容易地改变，并放在不同的工作表上。

首先，在已重命名的类模块中输入以下代码＆＃34; CodeData＆＃34;

Option Explicit
Private pData As String
Private pCode As String

Property Get Data() As String
    Data = pData
End Property
Property Let Data(Value As String)
    pData = Value
End Property

Property Get Code() As String
    Code = pCode
End Property
Property Let Code(Value As String)
    pCode = Value
End Property

然后将以下代码放入常规模块中：

Option Explicit
Sub ParseCodesAndData()
    Dim cCodeData As CodeData
    Dim colCodeData As Collection
    Dim vSrc As Variant, vRes() As Variant
    Dim V As Variant
    Dim rRes As Range
    Dim I As Long, J As Long

'Results start here. But could be on another sheet
Set rRes = Range("D1:E1")

'Get Source Data
vSrc = Range("A1", Cells(Rows.Count, "B").End(xlUp))

'Collect the data
Set colCodeData = New Collection
For I = 1 To UBound(vSrc, 1)
    V = Split(vSrc(I, 1), " ")
    For J = 0 To UBound(V)
        Set cCodeData = New CodeData
        cCodeData.Code = Trim(vSrc(I, 2))
        cCodeData.Data = Trim(V(J))
    colCodeData.Add cCodeData
    Next J
Next I

'Write results to array
ReDim vRes(1 To colCodeData.Count, 1 To 2)
For I = 1 To UBound(vRes)
    Set cCodeData = colCodeData(I)
    vRes(I, 1) = cCodeData.Data
    vRes(I, 2) = cCodeData.Code
Next I

'Write array to worksheet
Application.ScreenUpdating = False

rRes.EntireColumn.Clear
rRes.Resize(rowsize:=UBound(vRes, 1)) = vRes

Application.ScreenUpdating = True

End Sub

Answer 6

这是我在上面的帮助下设计的解决方案。谢谢你的回复！

Sub Splt()
    Dim LR As Long, i As Long
    Dim X As Variant
    Application.ScreenUpdating = False
    LR = Range("A" & Rows.Count).End(xlUp).Row
    Columns("A").Insert
    For i = LR To 1 Step -1
        With Range("B" & i)
            If InStr(.Value, " ") = 0 Then
                .Offset(, -1).Value = .Value
            Else
                X = Split(.Value, " ")
                .Offset(1).Resize(UBound(X)).EntireRow.Insert
                .Offset(, -1).Resize(UBound(X) - LBound(X) + 1).Value =            Application.Transpose(X)
            End If
        End With
    Next i
    Columns("B").Delete
    LR = Range("A" & Rows.Count).End(xlUp).Row
    With Range("B1:C" & LR)
        On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        On Error GoTo 0
        .Value = .Value
    End With
    Application.ScreenUpdating = True
    End Sub

VBA - 将字符串拆分为单个单元格

6 个答案: