求助，提取个人明细表。之前网友帮我写了个，表格改动，自己改不来

修炼中的鱼 · 发表于 2020-1-15 13:13

本帖最后由修炼中的鱼于 2020-1-15 13:29 编辑

liulang0808 · 发表于 2020-1-15 13:17

楼主的附件代码加密了
建议上传取消密码的附件并说明具体变化
http://club.excelhome.net/thread-1385473-1-1.html一些字典的案例，楼主可以参考

修炼中的鱼 · 发表于 2020-1-15 13:29

liulang0808 发表于 2020-1-15 13:17
楼主的附件代码加密了
建议上传取消密码的附件并说明具体变化
http://club.excelhome.net/thread-1385473 ...

谢谢您已经重新上传了

y1983y · 发表于 2020-1-15 13:44

你原表格呢？建议也一同上传

修炼中的鱼 · 发表于 2020-1-15 13:53

y1983y 发表于 2020-1-15 13:44
你原表格呢？建议也一同上传

压缩包里面就是

y1983y · 发表于 2020-1-15 15:35

修炼中的鱼发表于 2020-1-15 13:53
压缩包里面就是

表格改动前的工作簿

修炼中的鱼 · 发表于 2020-1-15 15:54

以前师这一份后面表格改进了

修炼中的鱼 · 发表于 2020-1-15 15:58

y1983y 发表于 2020-1-15 15:35
表格改动前的工作簿

已发楼下，麻烦您了

liulang0808 · 发表于 2020-1-15 20:28

Sub 统计()
Rows("4:1000").Delete
Dim m, n, i, j, k, t, arr, brr, d As Object
Set d = CreateObject("scripting.dictionary")
arr = Sheets("登记表").Range("A1").CurrentRegion
For i = 3 To UBound(arr)
For j = 2 To 8
If arr(i, j) <> "" Then
If i Mod 2 = 1 Then
r = i
Else
r = i - 1
End If
If Not d.exists(arr(i, j)) Then
ReDim brr(1 To 3)
brr(1) = Val(arr(r, 11))
brr(2) = Format(arr(r, 9), "yyyy-mm-dd") & "@@" & Format(arr(r, 10), "yyyy-mm-dd")
brr(3) = 1
d(arr(i, j)) = brr
Else
brr = d(arr(i, j))
brr(1) = Val(arr(r, 11)) + brr(1)
brr(2) = brr(2) & "@@" & Format(arr(r, 9), "yyyy-mm-dd") & "@@" & Format(arr(r, 10), "yyyy-mm-dd")
brr(3) = 1 + brr(3)
d(arr(i, j)) = brr
End If
End If
Next
Next
k = d.keys
t = d.items
For x = 0 To d.Count - 1
n = n + 1
Cells(n + 3, 1) = n
Cells(n + 3, 2) = k(x)
Cells(n + 3, 3) = t(x)(3)
Cells(n + 3, 4) = t(x)(1)
brr = Split(t(x)(2), "@@")
Cells(n + 3, 5).Resize(1, UBound(brr) + 1) = brr
Next
Set d = Nothing
End Sub

复制代码

liulang0808 · 发表于 2020-1-15 20:29

附件内容供参考。。。。。。

		自动登录	找回密码
密码			免费注册