拆分单元格

jordanlive

请帮忙解决下，拆分单元格，并统计出现次数的VB程序语句

清风竹-

请参考。。。。。

jordanlive

清风竹- 发表于 2024-8-23 20:36
请参考。。。。。

出来的结果是还不行，同一个位置不能累计，有点错误5能不能重第14行开始，第13行为空白

清风竹-

jordanlive 发表于 2024-8-24 08:45
出来的结果是还不行，同一个位置不能累计，有点错误5能不能重第14行开始，第13行为空白

修改了一下。

jordanlive

清风竹- 发表于 2024-8-24 10:41
修改了一下。

感谢老师，我已经把语句修了，能够实现想要的功能了。

清风竹-

jordanlive 发表于 2024-8-26 08:50
感谢老师，我已经把语句修了，能够实现想要的功能了。

这次是否符合要求

jordanlive

清风竹- 发表于 2024-8-26 09:58
这次是否符合要求

Sub 流水线表填数据()
    ' 获取“日报表”中 D 列最后一个有数据的单元格的行号
    m = Sheets("日报表").[d65536].End(3).row
   
    ' 将“日报表”特定范围的数据存入数组
    ar1 = Sheets("日报表").Range("d7:d" & m)
    ar2 = Sheets("日报表").Range("t7:bX" & m)
    ar3 = Sheets("日报表").Range("bY7:bY" & m)
   
    ' 获取“流水线”工作表中 B1 单元格的值和特定范围
    b1 = Sheets("流水线").[b1]
    br1 = Sheets("流水线").Range("N8:W8")
   
    ' 重新定义数组 brr 的大小
    ReDim brr(1 To UBound(ar2, 2) + 1, 1 To UBound(br1, 2) + 1)
   
    ' 创建字典对象
    Set d = CreateObject("scripting.dictionary")
  
    ' 将 br1 中每个单元格的值存入字典，以其值为键，列索引为值
    For i = 1 To UBound(br1, 2)
          d(br1(1, i) & "") = i
    Next

    ' 遍历 ar1 数组（日报表中 D 列的数据范围）
    For i = 1 To UBound(ar1)
        ' 如果 ar1 中的当前值等于“流水线”工作表中 B1 的值，并且 ar3 中对应位置的值长度大于 0
        If ar1(i, 1) = b1 And Len(ar3(i, 1)) > 0 Then
            ' 将 ar3 中当前行的值以“；”为分隔符分割成数组 A
            A = Split("；" & ar3(i, 1), "；")
            n = 0
            ' 遍历 ar2 数组（日报表中 R7 到 BV 列的数据范围）的列数
            For j = 1 To UBound(ar2, 2)
                ' 根据条件调整列索引
                If j > 4 Then j2 = j + 1 Else j2 = j
                ' 如果 ar2 中当前行当前列的值大于 0
                If ar2(i, j) > 0 Then
                    For counter = 1 To ar2(i, j) '根据当前单元格数值进行循环判断
                        ' 在这里添加循环中要执行的代码
                        n = n + 1
                        If n <= UBound(A) Then ' 防止超出 A 数组的范围
                            zrr = A(n)
                            l = d(zrr)
                            ' 检查索引是否越界
                            If j2 <= UBound(brr, 1) And l <= UBound(brr, 2) Then
                                ' 判断当前单元格是否已有值，如果有则进行累计
                                If brr(j2, l) <> "" Then
                                    brr(j2, l) = brr(j2, l) + 1
                                Else
                                    brr(j2, l) = 1
                                End If
                            Else
                                Debug.Print "Index out of bounds. j2: " & j2 & ", l: " & l
                            End If
                        Else
                            Exit For ' 如果超出 A 数组范围，退出循环
                        End If
                    Next counter
                End If
            Next
        End If
    Next
  
    ' 将填充好的 brr 数组赋值到“流水线”工作表中，从 N9 单元格开始
    Sheets("流水线").Range("N9").Resize(UBound(ar2, 2) + 1, UBound(br1, 2)) = brr
End Sub
   
日报表中增加了两列，现在运行提示下标越界，是什么原因

jordanlive

清风竹- 发表于 2024-8-26 09:58
这次是否符合要求

是的，现在符合要求了，感谢老师