只能提取1个月的数据

hhxq001

表中提取了6月的数据，无法提取7月的，问题出在哪里


2月-无法提取7月的.rar (326.27 KB, 下载次数: 15)

2024-7-23 10:41 上传

点击文件名下载附件

longwin

主要问题：7月份的身份证号码都是同一个

ykcbf1100

感觉写得不简明，想改，但短时间内看不清楚，放弃了。

Yalishanda30

7月人员都是a0000001.。。

chxw68

修改好了。提取不到7份数据的原因是7月份所有行数据都是同一个身份证号码。

chxw68

修改好了。

chxw68

重新写了一段。

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Dim ws As Worksheet
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set d_ws = CreateObject("scripting.dictionary")
   
8.     For Each ws In Worksheets
   
9.         d_ws(ws.Name) = Empty
   
10.     Next
    
11.     With Worksheets("测算两月比较")
    
12.         cs = .Range("d2")
    
13.         yf = .Range("e3:f3")
    
14.         .Range("a5:g" & .Rows.Count).ClearContents
    
15.     End With
    
16.    
    
17.     If Not d_ws.exists(yf(1, 1) & "月税") Or Not d_ws.exists(yf(1, 2) & "月税") Then
    
18.         MsgBox "相关月份数据不存在！"
    
19.         Exit Sub
    
20.     End If
    
21.    
    
22.     For k = 1 To UBound(yf, 2)
    
23.         With Worksheets(yf(1, k) & "月税")
    
24.             .AutoFilterMode = False
    
25.             r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
26.             arr = .Range("a7:h" & r)
    
27.             For i = 1 To UBound(arr)
    
28.                 If Not d.exists(arr(i, 4)) Then
    
29.                     ReDim brr(1 To 7)
    
30.                     brr(2) = arr(i, 2)
    
31.                     brr(3) = arr(i, 4)
    
32.                     brr(4) = arr(i, 5)
    
33.                 Else
    
34.                     brr = d(arr(i, 4))
    
35.                 End If
    
36.                 If cs = "月初" Then
    
37.                     brr(4 + k) = brr(4 + k) + arr(i, 7)
    
38.                 Else
    
39.                     brr(4 + k) = brr(4 + k) + arr(i, 8)
    
40.                 End If
    
41.                 d(arr(i, 4)) = brr
    
42.             Next
    
43.         End With
    
44.     Next
    
45.     ReDim crr(1 To d.Count, 1 To 7)
    
46.     m = 0
    
47.     For Each aa In d.keys
    
48.         brr = d(aa)
    
49.         brr(7) = brr(5) - brr(6)
    
50.         m = m + 1
    
51.         crr(m, 1) = m
    
52.         For j = 2 To UBound(brr)
    
53.             crr(m, j) = brr(j)
    
54.         Next
    
55.     Next
    
56.     With Worksheets("测算两月比较")
    
57.         With .Range("a5").Resize(UBound(crr), UBound(crr, 2))
    
58.             .Value = crr
    
59.             .Borders.LineStyle = xlContinuous
    
60.         End With
    
61.     End With
    
62.                
    
63. End Sub
    

复制代码

chxw68

重新写了一段，供楼主参考。

chxw68

修改了浮点数运算问题。

hhxq001

longwin 发表于 2024-7-23 10:52
主要问题：7月份的身份证号码都是同一个

谢谢提醒。为了省事选中de列下拉的，没注意都成了001