Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3583|回复: 16

[已解决]横向追加数据,根据工序汇总产量。

[复制链接]
发表于 2015-3-9 22:18 | 显示全部楼层 |阅读模式
本帖最后由 张雄友 于 2015-3-11 18:34 编辑

横向追加数据,根据工序汇总产量。

最佳答案
2015-3-11 08:49
从管理数据的角度看,每列数据(文本类)的长度应该一致
Sub dsmch()
Dim arr, brr, d, d2, i&, j&, k&, zf
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("A1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 200)
For i = 2 To UBound(arr)
    arr(i, 1) = Right(String(6, "0") & arr(i, 1), 6)  
  zf = arr(i, 1) & "," & arr(i, 3)
    If Not d.Exists(arr(i, 1)) Then
        h = h + 1
        d(arr(i, 1)) = h
        brr(h, 1) = arr(i, 1)
    End If
    If Not d2.Exists(zf) Then
       d2(zf) = i
    Else
       d2(zf) = d2(zf) & "," & i
    End If
Next
a = d2.Keys: b = d2.Items: zdl = 0
For i = 1 To h
    L = 1
    For j = 0 To d2.Count - 1
        mc = Split(a(j), ",")(1) '工序名称
        If a(j) Like brr(i, 1) & "*" Then
            L = L + 1
            x = Split(b(j), ",")
            p = "": s = 0
            For k = 0 To UBound(x)
                If InStr(p, arr(x(k), 2)) = 0 Then p = p & "/" & arr(x(k), 2) '制单号去重复!
                s = s + arr(x(k), 4)
            Next
            z = Mid(p, 2)
            zf2 = IIf(InStr(z, "/"), "(" & z & ")", z)
            brr(i, L) = zf2 & " " & mc & " " & s
       End If
    Next
    If L > zdl Then zdl = L
Next
Range("G18").Resize(h, zdl) = brr
Range("G18").Resize(h, zdl).Borders.LineStyle = xlContinuous
End Sub

横向追加数据.png

横向追加数据.rar

13.53 KB, 下载次数: 15

发表于 2015-3-10 11:29 | 显示全部楼层
  1. Sub Macro1()
  2. Dim arr, brr, d, d2, i&, j%, k%, zf
  3. Set d = CreateObject("scripting.dictionary")
  4. Set d2 = CreateObject("scripting.dictionary")
  5. arr = Range("a1").CurrentRegion
  6. ReDim brr(1 To UBound(arr), 1 To 200)
  7. For i = 2 To UBound(arr)
  8.     zf = arr(i, 1) & "," & arr(i, 3)
  9.     If Not d.exists(arr(i, 1)) Then
  10.         h = h + 1
  11.         d(arr(i, 1)) = h
  12.         brr(h, 1) = arr(i, 1)
  13.     End If
  14.     If Not d2.exists(zf) Then
  15.        d2(zf) = i
  16.     Else
  17.        d2(zf) = d2(zf) & "," & i
  18.     End If
  19. Next
  20. a = d2.keys: b = d2.items: zdl = 0
  21. For i = 1 To h
  22.     L = 1
  23.     For j = 0 To d2.Count - 1
  24.         mc = Split(a(j), ",")(1) '工序名称
  25.         If a(j) Like brr(i, 1) & "*" Then
  26.             L = L + 1
  27.             x = Split(b(j), ",")
  28.             p = "": s = 0
  29.             For k = 0 To UBound(x)
  30.                 p = p & "/" & arr(x(k), 2)
  31.                 s = s + arr(x(k), 4)
  32.             Next
  33.             z = Mid(p, 2)
  34.             zf2 = IIf(InStr(z, "/"), "(" & z & ")", z)
  35.             brr(i, L) = zf2 & " " & mc & " " & s
  36.        End If
  37.     Next
  38.     If L > zdl Then zdl = L
  39. Next
  40. Range("g8").Resize(h, zdl) = brr
  41. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-3-10 18:06 | 显示全部楼层
dsmch 发表于 2015-3-10 11:29

制单号没有去重复。

横向追加数据1.rar

14.83 KB, 下载次数: 3

回复

使用道具 举报

发表于 2015-3-11 06:56 | 显示全部楼层
Sub Macro1()
Dim arr, brr, d, d2, i&, j%, k%, zf
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 200)
For i = 2 To UBound(arr)
    zf = arr(i, 1) & "," & arr(i, 3)
    If Not d.exists(arr(i, 1)) Then
        h = h + 1
        d(arr(i, 1)) = h
        brr(h, 1) = arr(i, 1)
    End If
    If Not d2.exists(zf) Then
       d2(zf) = i
    Else
       d2(zf) = d2(zf) & "," & i
    End If
Next
a = d2.keys: b = d2.items: zdl = 0
For i = 1 To h
    L = 1
    For j = 0 To d2.Count - 1
        mc = Split(a(j), ",")(1) '工序名称
        If a(j) Like brr(i, 1) & "*" Then
            L = L + 1
            x = Split(b(j), ",")
            p = "": s = 0
            For k = 0 To UBound(x)
                If InStr(p, arr(x(k), 2)) = 0 Then p = p & "/" & arr(x(k), 2)
                s = s + arr(x(k), 4)
            Next
            z = Mid(p, 2)
            zf2 = IIf(InStr(z, "/"), "(" & z & ")", z)
            brr(i, L) = zf2 & " " & mc & " " & s
       End If
    Next
    If L > zdl Then zdl = L
Next
Range("g8").Resize(h, zdl) = brr
End Sub
回复

使用道具 举报

 楼主| 发表于 2015-3-11 07:48 | 显示全部楼层
dsmch 发表于 2015-3-11 06:56
Sub Macro1()
Dim arr, brr, d, d2, i&, j%, k%, zf
Set d = CreateObject("scripting.dictionary")

出错的,应该是  If a(j) Like brr(i, 1) & "*" Then   不能用模糊匹配。最后一个人,工号是 1 的汇总出错。

横向追加数据出错.rar

15.31 KB, 下载次数: 6

回复

使用道具 举报

发表于 2015-3-11 08:49 | 显示全部楼层    本楼为最佳答案   
从管理数据的角度看,每列数据(文本类)的长度应该一致
Sub dsmch()
Dim arr, brr, d, d2, i&, j&, k&, zf
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr = Range("A1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 200)
For i = 2 To UBound(arr)
    arr(i, 1) = Right(String(6, "0") & arr(i, 1), 6)  
  zf = arr(i, 1) & "," & arr(i, 3)
    If Not d.Exists(arr(i, 1)) Then
        h = h + 1
        d(arr(i, 1)) = h
        brr(h, 1) = arr(i, 1)
    End If
    If Not d2.Exists(zf) Then
       d2(zf) = i
    Else
       d2(zf) = d2(zf) & "," & i
    End If
Next
a = d2.Keys: b = d2.Items: zdl = 0
For i = 1 To h
    L = 1
    For j = 0 To d2.Count - 1
        mc = Split(a(j), ",")(1) '工序名称
        If a(j) Like brr(i, 1) & "*" Then
            L = L + 1
            x = Split(b(j), ",")
            p = "": s = 0
            For k = 0 To UBound(x)
                If InStr(p, arr(x(k), 2)) = 0 Then p = p & "/" & arr(x(k), 2) '制单号去重复!
                s = s + arr(x(k), 4)
            Next
            z = Mid(p, 2)
            zf2 = IIf(InStr(z, "/"), "(" & z & ")", z)
            brr(i, L) = zf2 & " " & mc & " " & s
       End If
    Next
    If L > zdl Then zdl = L
Next
Range("G18").Resize(h, zdl) = brr
Range("G18").Resize(h, zdl).Borders.LineStyle = xlContinuous
End Sub

评分

参与人数 1 +6 收起 理由
张雄友 + 6 有否优化的空间?

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-3-11 20:16 | 显示全部楼层
本帖最后由 张雄友 于 2015-3-11 20:27 编辑
dsmch 发表于 2015-3-11 08:49
从管理数据的角度看,每列数据(文本类)的长度应该一致
Sub dsmch()
Dim arr, brr, d, d2, i&, j&, k&,  ...

6万多行数据要5分钟左右,有否优化的空间?

点评

把结果的格式改为分开存放  发表于 2015-3-12 07:23
回复

使用道具 举报

 楼主| 发表于 2015-3-12 07:31 | 显示全部楼层
dsmch 发表于 2015-3-11 08:49
从管理数据的角度看,每列数据(文本类)的长度应该一致
Sub dsmch()
Dim arr, brr, d, d2, i&, j&, k&,  ...

把结果的格式改为分开存放 ?怎么分开存放?希望这不是追 加要求(附上实际工作模型)。谢谢!
但是同一个人的要在同一行显示的。

以工序为参照系制单号为辅助统计产量办法.rar

15.55 KB, 下载次数: 9

回复

使用道具 举报

发表于 2015-3-12 10:10 | 显示全部楼层
改成如下格式,循环一次便可完成
123456        车筒        SJ1001/SJ2036/SJ2037        35906
123456        纳膊         SJ1001        22463
回复

使用道具 举报

 楼主| 发表于 2015-3-12 18:03 | 显示全部楼层
dsmch 发表于 2015-3-12 10:10
改成如下格式,循环一次便可完成
123456        车筒        SJ1001/SJ2036/SJ2037        35906
123456        纳膊         SJ1001        22463

同一个员工分成二行,或者多行显示,不方便取数。目的是要同一个员工在同一行显示,如果一个员工有做多个工序,就是向右追加数据的。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 18:13 , Processed in 0.480159 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表