VBA协助在单元格中的半冒号之间分离字符串并单独复制每个字符串 - 请参阅下面的示例 [英] VBA assistance to separate out strings between semi colons in cells and copy each individually - see example below

问题描述

你好，



我有一个程序根据一列中发现的半冒号复制一整行。

列的格式可以是AAA; BBB; CCC当程序运行后的结果是 



第1行AAA; BBB; CCC

第2行AAA; BBB; CCC

第3行AAA; BBB; CCC



我想要发生的是它最终结算为


行1 AAA

第2行BBB

第3行CCC



到目前为止我的代码如下。如有任何建议，请提前感谢。





$
Const ROW_FIRST As Integer = 1

Private Const ROW_LAST As Integer = 100



Sub CopySemi



$
Dim iRow As Integer，iRowsAdded As Integer，iSemicolons As Integer，i As Integer，j As Integer

    Dim sCell（1 To 7）As String

    iRow = ROW_FIRST

  &NBSP;做iRow< ROW_LAST + iRowsAdded

  &NBSP; &NBSP; &NBSP;对于i = 1到7

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; sCell（i）= Me.Cells（iRow，i）.Value

  &NBSP; &NBSP; &NBSP;接下来我是
  &NBSP; &NBSP; &NBSP; iSemicolons = Len（sCell（2）） - Len（替换（sCell（2），";"，""）））
  &NBSP; &NBSP; &NBSP;如果iSemicolons> 0然后

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP;对于j = 1到iSemicolons

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; iRow = iRow + 1

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; Me.Rows（iRow）.Insert

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP;对于i = 1到7

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; Me.Cells（iRow，i）.Value = sCell（i）

  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP; &NBSP;接下来我是
  &NBSP; &NBSP; &NBSP; &NBSP; &NBSP;下一个j

  &NBSP; &NBSP; &NBSP;结束如果

  &NBSP; &NBSP; &NBSP; iRow = iRow + 1

  &NBSP;循环

结束子

谢谢。

  

 Sub CopySemi（）
 Dim iRow As Integer，i As Integer，j As Integer 
 Dim arr 
 For iRow = ROW_LAST To ROW_FIRST Step -1 
 arr = Split（Me.Cells（iRow，2）.Value，" ;"）
如果UBound（arr）> 0然后
 For j = UBound（arr）To 1 Step -1 
 Rows（iRow + 1）.Insert 
 For i = 1 To 7 
 if i = 2 Then 
 Me.Cells（iRow + 1，i）.Value = arr（j）
 Else 
 Me.Cells（iRow + 1，i）.Value = Cells（iRow，i）.Value 
结束如果
下一个i 
下一个j 
 Me.Cells（iRow，2）= arr（0）
结束如果
下一个iRow 
结束子

Hello,

I have a program that copies an entire row dependent upon how many semi colons found in a column.
The format of the column can be AAA;BBB;CCC When result after the program is run is 

row 1 AAA;BBB;CCC
row 2 AAA;BBB;CCC
row 3 AAA;BBB;CCC

What I would like to happen is it to end up as so

row 1 AAA
row 2 BBB
row 3 CCC

The code I have so far is below. Thank you in advance for any suggestions.



Const ROW_FIRST As Integer = 1
Private Const ROW_LAST As Integer = 100

Sub CopySemi


Dim iRow As Integer, iRowsAdded As Integer, iSemicolons As Integer, i As Integer, j As Integer
    Dim sCell(1 To 7) As String
    iRow = ROW_FIRST
    Do While iRow < ROW_LAST + iRowsAdded
        For i = 1 To 7
            sCell(i) = Me.Cells(iRow, i).Value
        Next i
        iSemicolons = Len(sCell(2)) - Len(Replace(sCell(2), ";", ""))
        If iSemicolons > 0 Then
            For j = 1 To iSemicolons
                iRow = iRow + 1
                Me.Rows(iRow).Insert
                For i = 1 To 7
                    Me.Cells(iRow, i).Value = sCell(i)
                Next i
            Next j
        End If
        iRow = iRow + 1
    Loop
End Sub

Thank you.

  

解决方案

Try this:

Sub CopySemi()
    Dim iRow As Integer, i As Integer, j As Integer
    Dim arr
    For iRow = ROW_LAST To ROW_FIRST Step -1
        arr = Split(Me.Cells(iRow, 2).Value, ";")
        If UBound(arr) > 0 Then
            For j = UBound(arr) To 1 Step -1
                Rows(iRow + 1).Insert
                For i = 1 To 7
                    If i = 2 Then
                        Me.Cells(iRow + 1, i).Value = arr(j)
                    Else
                        Me.Cells(iRow + 1, i).Value = Cells(iRow, i).Value
                    End If
                Next i
            Next j
            Me.Cells(iRow, 2) = arr(0)
        End If
    Next iRow
End Sub

这篇关于VBA协助在单元格中的半冒号之间分离字符串并单独复制每个字符串 - 请参阅下面的示例的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！