Vba 拆分已定界的值

交易单

 ID1  Name Amount ID2 
 123   A     1   0;124;0 
 456   B     2   124;0;0  
 789   C     3   456;0;0

交易记录表（预期结果）

我已经尝试过文本到列，但我不确定如何忽略所有的0，并且只在其>0时在列D中显示该值。我是vba新手，因此希望能就此提供一些建议，以便我可以学习

代码：

Sub-SplitRange（）
暗淡单元格作为范围
Dim str作为变量的字符串数组
作为整数的Dim r
对于ActiveSheet.UsedRange中的每个cel
如果InStr（cell.Value，“；”）大于0，则“拆分”
str=拆分（cell.Value，“；”）
对于r=LBound（str）到UBound（str）
单元偏移（r）.值=修剪（str（r））
如果r

那么，您想将非0值串联成一个字符串，然后将其放入下一个单元格

Sub SplitRange()
    Dim workcell As Range
    Dim str() As String 'string array
    Dim r As Long 'VBA automatically stores Integers as Longs, so there is no Memory saved by not using Long
    Dim output As String
    output = ";" 'Start with a single delimiter

    For Each workcell In Intersect(ActiveSheet.UsedRange,ActiveSheet.Columns(4)) 'Go down the cells in Column D
        If InStr(workcell.Value, ";") > 0 Then 'split
            str = Split(workcell.Value,";")
            For r = LBound(str) To UBound(str)
                If inStr(output, ";" & Trim(str(r)) & ";") < 1 Then 'If number is not already in output
                    output = output & Trim(str(r)) & ";" 'Add the number and ";" to the end of the string
                End If
            Next r
            Erase str 'Tidy up array, ready to recycle
        End If
    Next workcell
    'We now have a unique list of all items, starting/ending/delimited with ";"
    output = Replace(output,";0;",";") 'Remove the item ";0;" if it exists
    If Len(output) > 2 Then 'output contains at least 1 non-zero number
        output= Mid(output,2,len(output)-2) 'Remove ";" from the start and end
        str = Split(output,";") 'Split the list of unique values into an array
        For r = lbound(str) To ubound(str)
            ActiveSheet.Cells(r+2-lbound(str),5).Value = str(r) 'List the values in column 5, starting from row 2
        Next r
        Erase str 'Tidy up array
    End If
End Sub

由内而外：

替换（“|”&A1&“|”、“0；”、“；”）

将我们的值夹在包装器中（

“| 0；240；0；|”

），并将任何“0；”替换为“；”（

“| 240；|”

）

替换（上一个“；|”和“）

删除“；|”（

“| 240”

）

替换（上一个“|”，”）

删除“|”（

“240”

）

早上好

此处需要将条目拆分为一个数组，然后在循环数组时检查数组的值：

Sub SplitString()

Dim TempArray() As String
Dim i as Integer
Dim j As Integer


For i = 1 To 10

    TempArray = Split(Worksheets("Sheet1").Cells(i,4).Value,";")

    For j = 0 to UBound(TempArray)

        If CDbl(TempArray(j)) <> 0 Then

              [Output value]

        End if

    Next j

Next i

End Sub

Sub-SplitString（）
Dim TempArray（）作为字符串
作为整数的Dim i
作为整数的Dim j
对于i=1到10
TempArray=Split（工作表（“Sheet1”）。单元格（i，4）。值“；”）
对于j=0到uBond（TempArray）
如果CDbl（TempArray（j））为0，则
[产值]
如果结束
下一个j
接下来我
端接头

创建一个比1=1到10更有用的循环，但是你得到了这个想法

注：在上文中：

---

-CDbl是为了确保检查将其读取为一个数字而不是一个文本字符串。

首先，我们不应该遍历所有使用过的单元格，而应该只遍历我们需要的ID2所在的行，这要快得多

最简单的方法就是删除所有

；0

和

0则只保留该值。如果始终只有一个实值不是
0
，例如
0，则以下操作将起作用；124;0

Public Sub FindValueRangeInColumn()
    Const Col As Long = 4   'the column where the ID2 is in

    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet

    Dim lRow As Long
    lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row 'find last used row in column

    Dim iRow As Long
    For iRow = 2 To lRow 'loop throug rows from 2 to last used row
        Dim strSource As String
        strSource = ws.Cells(iRow, Col) 'read value

        strSource = Replace(ws.Cells(iRow, Col), ";0", "") 'remove all ;0
        If Left$(strSource, 2) = "0;" Then strSource = Right$(strSource, Len(strSource) - 2) 'remove 0; from the beginnning

        ws.Cells(iRow, Col + 1).Value = strSource 'write value
    Next iRow
End Sub

如果可以有多个非零值，如
0；124;0;222;0;0;144
然后更换

ws.Cells(iRow, Col + 1).Value = strSource 'write value

有一个分裂的选择

    If InStr(1, strSource, ";") > 1 Then
        Dim SplitValues As Variant
        SplitValues = Split(strSource, ";")
        Dim iValue As Long
        For iValue = LBound(SplitValues) To UBound(SplitValues)
            ws.Cells(iRow, Col + 1 + iValue).Value = SplitValues(iValue) 'write value
        Next iValue
    Else
        ws.Cells(iRow, Col + 1).Value = strSource 'write value
    End If

欢迎来到堆栈溢出。如果您想在VBA中实现这一点，您首先需要自己动手。这是一个基于问答的网站，在这里你可以询问与你自己编写的代码相关的问题，这些代码会被卡住或出错。人们会乐于帮助您自己解决代码中的问题，但他们不会为您编写所有代码。此外，在这里要求一般性指导或教学也过于宽泛。您可能需要阅读或阅读以改进您的问题（您至少需要问一个）。同位语，我已经添加了我使用的代码，我在获取摘要部分时遇到了问题。拆分是可以的。我建议使用
选项Explicit
，以避免变量命名方面的任何问题。您最大的问题是，您曾经使用过
cel
，而另一方面，您使用的是
cell
。还可以看看下面的公式解决方案，在这里您根本不需要VBA。我想使用VBA来自动处理HI，下标超出范围“r=lbound（str）到ubound（str）您好，谢谢。我如何在下一列中包含唯一Id？根据问题描述中显示的我的预期结果。此外，如果有多个0，而不是只有一个，那么公式不起作用。有没有办法对所有0进行此操作？即100,0,0,0,0,0,0,0,0,0,0,0将返回100。@GLH更新-我将太多的现有代码删除了正在调整。抱歉！感谢您在这方面的帮助。您能提供建议吗？请检查我的预期结果吗？I，这会在我为I=1到10000C所做的第1行产生编译错误。您能提供建议吗？抱歉，第一个TempArray需要括号，即Dim TempArray（）正如我在上面编辑的字符串。嗨，GLH-如果现在一切都清楚了，请向上投票，并通过单击勾号将其标记为解决方案。
Public Sub FindValueRangeInColumn()
    Const Col As Long = 4   'the column where the ID2 is in

    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet

    Dim lRow As Long
    lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row 'find last used row in column

    Dim iRow As Long
    For iRow = 2 To lRow 'loop throug rows from 2 to last used row
        Dim strSource As String
        strSource = ws.Cells(iRow, Col) 'read value

        strSource = Replace(ws.Cells(iRow, Col), ";0", "") 'remove all ;0
        If Left$(strSource, 2) = "0;" Then strSource = Right$(strSource, Len(strSource) - 2) 'remove 0; from the beginnning

        ws.Cells(iRow, Col + 1).Value = strSource 'write value
    Next iRow
End Sub

ws.Cells(iRow, Col + 1).Value = strSource 'write value

    If InStr(1, strSource, ";") > 1 Then
        Dim SplitValues As Variant
        SplitValues = Split(strSource, ";")
        Dim iValue As Long
        For iValue = LBound(SplitValues) To UBound(SplitValues)
            ws.Cells(iRow, Col + 1 + iValue).Value = SplitValues(iValue) 'write value
        Next iValue
    Else
        ws.Cells(iRow, Col + 1).Value = strSource 'write value
    End If