Question

我被要求拆分一堆看起来像这样的单元格：

在：

Upld for #: 16 Submit URL 
HY-Upld & Attstn for #: 17 Upload Materials
HY-Attstn, Chklst & Upld for #: 31 Upload Proofs

我看到的唯一模式是某些单元格具有'＆amp;'字符，而某些单元格具有'，'以及'＆amp;'。我试图找出一种基于'＆amp;'和'，'字符解析行的方法。所以，我的'Before'可以转化为我的'After'。

后：

Upld for #: 16 Submit URL 
HY-Upld for #: 17 Upload Materials
Attstn for #: 17 Upload Materials
HY-Attstn for #: 31 Upload Proofs
Chklst for #: 31 Upload Proofs
Upld for #: 31 Upload Proofs

所有记录都在ColumnA中，这可能会使这更容易一些。我可以预见的是分裂单元格，就像我在下面的代码示例中所做的那样，并根据两个字符'＆amp;'和'，'对每个分割进行复制。据我所知，问题是我可以分割出一个字符，但不能同时分开。

Dim iRow As Long, nRows As Long
Dim arr As Variant
    With Sheets("Forms_Labels")
        For iRow = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
            With .Cells(iRow, 1)
                arr = Split(.Offset(, 0).Value, "&")
                nRows = UBound(arr)
                On Error Resume Next
                .Offset(1).Resize(nRows).EntireRow.Insert xlShiftDown
                .Resize(nRows + 1).Value = .Value
                .Offset(, 1).Resize(nRows + 1).Value = .Application.Transpose(arr)
                .Offset(, 2).Resize(nRows + 1).Value = .Offset(, 1).Value
            End With
        Next
    End With

我知道如何让这个概念有用吗？

Answer 1

这将是我的方法（基于我上面的评论）：

Option Base 0
Option Explicit

Public Sub tmpSO()

Dim arrToDo, arrWhat
Dim strWhat As String
Dim sourceList(), resultList() As String
Dim wsSheet As Worksheet
Dim iRow As Long, nRows As Long

Set wsSheet = Sheets("Forms_Labels")
sourceList = wsSheet.Range("A1:A" & wsSheet.Cells(wsSheet.Rows.Count, 1).End(xlUp).Row).Value2

ReDim resultList(0)
For iRow = LBound(sourceList) To UBound(sourceList)
    arrToDo = Split(sourceList(iRow, 1), "#")
    strWhat = arrToDo(0)
    strWhat = Trim(Replace(strWhat, "for", ""))
    strWhat = Replace(Replace(strWhat, ",", " "), "&", " ")
    While InStr(1, strWhat, "  ")
        strWhat = Replace(strWhat, "  ", " ")
    Wend
    arrWhat = Split(strWhat, " ")
    For nRows = LBound(arrWhat) To UBound(arrWhat)
        resultList(UBound(resultList)) = arrWhat(nRows) & " for #" & arrToDo(1)
        ReDim Preserve resultList(UBound(resultList) + 1)
    Next nRows
Next iRow

wsSheet.Range("A1:A" & UBound(resultList) + 1).Value2 = Application.Transpose(resultList)

End Sub

基于两个字符之一拆分单元格并向下复制

1 个答案: