Excel VBA：拆分字符串

Question

所以我对VBA真的很陌生，而且我遇到了一些问题。目标是在第1页上按下按钮，在第2页上按下文本到列。

到目前为止，我有这个代码（附在下面）。我的主要问题是我似乎无法将其水平分割，我也似乎无法将按钮放入其中。

任何帮助都会非常感激！

谢谢

我现在有什么：

Option Explicit

Sub splitcells()

    Dim InxSplit As Long
    Dim Splitcell() As String

    Dim RowCrnt As Long

    With Worksheets("sheet1")

        RowCrnt = 1
        Do While True

            If .Cells(RowCrnt, "A").Value = "" Then
                Exit Do
            End If

            Splitcell = Split(.Cells(RowCrnt, "A").Value, "/")
            If UBound(Splitcell) > 0 Then

                .Cells(RowCrnt, "A").Value = Splitcell(0)

                For InxSplit = 1 To UBound(Splitcell)
                    RowCrnt = RowCrnt + 1

                    .Rows(RowCrnt).EntireRow.Insert

                    .Cells(RowCrnt, "A").Value = Splitcell(InxSplit)

                    .Cells(RowCrnt, "B").Value = .Cells(RowCrnt - 1, "B").Value
                Next
            End If

            RowCrnt = RowCrnt + 1

        Loop

    End With

End Sub

Answer 1

如果您的值只是在A列下移，您就可以这样做。您需要在插入行时向后循环，并且可以使用通过拆分创建的数组，而不必遍历每个元素。

Sub x()

Dim r As Long, v

For r = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
    v = Split(Cells(r, 1), "/")
    If UBound(v) > 0 Then
        Cells(r, 1).Resize(UBound(v)).Insert shift:=xlDown
        Cells(r, 1).Resize(UBound(v) + 1).Value = Application.Transpose(v)
    End If
Next r

End Sub

Answer 2

如果要将列A单元格内容拆分为列，您可以按如下方式进行：

Sub SplitCells()
    With Worksheets("Sheet2") ' change "Sheet2" to the actual sheet name where this has to happen
        .Range("A1", .Cells(.Rows.count, 1).End(xlUp)).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="/"
    End With
End Sub

如果您希望在点击任何工作表中的按钮时发生这种情况，只需将该按钮附加到此SplitCells()子

Answer 3

你说水平和文本到列，但然后继续描述行拆分。

对于行：

如果将输出堆叠在不同的工作表中

Option Explicit
Sub splitcells()
    Dim rng As Range, counter As Long, nextRow As Long
    counter = 1
    For Each rng In Intersect(Worksheets("sheet1").Columns("A"), Worksheets("Sheet1").UsedRange)

        If counter = 1 Then
            Worksheets("Sheet2").Range(rng.Address).Resize(UBound(Split(Trim(rng), "/")) + 1, 1) = Application.Transpose(Split(rng, "/"))
            nextRow = UBound(Split(Trim(rng), "/"))

        Else
            Worksheets("Sheet2").Range(rng.Address).Offset(nextRow).Resize(UBound(Split(Trim(rng), "/")) + 1, 1) = Application.Transpose(Split(rng, "/"))
            nextRow = nextRow + UBound(Split(rng, "/"))
        End If

      counter = counter + 1
    Next rng
End Sub

或者

在同一张纸中（虽然这只是覆盖A列中的现有并延伸）

Option Explicit
Public Sub splitcells()
    Dim rng As Range, outputString As String
    With Worksheets("Sheet1")
       If Application.WorksheetFunction.CountIf(Intersect(.Columns("A"), .UsedRange), "*/*") = 0 Then Exit Sub
        For Each rng In Intersect(.Columns("A"), .UsedRange)
            If Not IsEmpty(rng) Then
                outputString = outputString & "/" & rng.Value
            End If
        Next rng
        outputString = Right$(outputString, Len(outputString) - 1)
        .Range("A1").Resize(UBound(Split(outputString, "/")) + 1, 1).Value = Application.Transpose(Split(outputString, "/"))
    End With
End Sub

如果将文字发送到不同表格中的列，则可能已经消失了：

Option Explicit
Sub splitcells()
    Application.ScreenUpdating = False
    Dim rng As Range

    For Each rng In Intersect(Worksheets("sheet1").Columns("A"), Worksheets("Sheet1").UsedRange)
       On Error Resume Next
        Worksheets("Sheet2").Range(rng.Address).Resize(1, UBound(Split(rng, "/")) + 1) = Split(rng, "/")
        On Error GoTo 0
    Next rng
    Application.ScreenUpdating = True
End Sub