[已解决]按月计数问题

王英wang

各位老师好：

帮忙看看用VAB 如何按月计数。

因附件太大，删掉部分啦，谢谢各位老师帮助。

最佳答案

月排行榜 / 总排行榜

grf1973

2017-1-23 09:54

1. Sub 获取数据()         
   
2.     Dim Fil
   
3.     ChDir ThisWorkbook.Path
   
4.     Fil = Application.GetOpenFilename(filefilter:="EXCEL 工作表(*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls")
   
5.     If Fil = False Then MsgBox "请选择文件！": Exit Sub
   
6.     Set wb = Workbooks.Open(Fil)        '打开文件
   
7.     arr = wb.Sheets(1).Range("a1:h" & wb.Sheets(1).[c65536].End(3).Row)
   
8.     wb.Close False
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     Set d1 = CreateObject("scripting.dictionary")
    
11.     For i = 2 To UBound(arr)
    
12.         x = arr(i, 3)
    
13.         If Len(x) > 0 Then
    
14.             d(x) = ""
    
15.             y = arr(i, 8)
    
16.             If IsDate(y) Then
    
17.                 y = Year(y) & "年" & Month(y) & "月"
    
18.                 d1(x & y) = d1(x & y) + 1
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     With ActiveSheet
    
23.         .[a6].Resize(1000, 200) = ""
    
24.         .[a6].Resize(d.Count) = Application.Transpose(d.keys)
    
25.         cmax = .Cells(5, 256).End(xlToLeft).Column
    
26.         arr = .[a4].Resize(d.Count + 2, cmax)
    
27.         For j = 2 To cmax
    
28.             If arr(1, j) = "" Then arr(1, j) = arr(1, j - 1)
    
29.         Next
    
30.         For i = 3 To UBound(arr)
    
31.             s = 0
    
32.             For j = 2 To cmax
    
33.                 xkey = arr(i, 1) & arr(1, j) & arr(2, j)
    
34.                 arr(i, j) = d1(xkey)
    
35.                 s = s + d1(xkey)
    
36.             Next
    
37.             If s = 0 Then arr(i, 1) = ""
    
38.         Next
    
39.         .[a4].Resize(d.Count + 2, cmax) = arr
    
40.         .Range("a5").Resize(d.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete   '删除无数据的行
    
41.     End With
    
42. End Sub

复制代码

跳转到最佳答案楼层

王英wang

请各位老师帮忙看看，谢谢

grf1973

1. Sub 获取数据()         
   
2.     Dim Fil
   
3.     ChDir ThisWorkbook.Path
   
4.     Fil = Application.GetOpenFilename(filefilter:="EXCEL 工作表(*.xlsx;*.xlsm;*.xls),*.xlsx;*.xlsm;*.xls")
   
5.     If Fil = False Then MsgBox "请选择文件！": Exit Sub
   
6.     Set wb = Workbooks.Open(Fil)        '打开文件
   
7.     arr = wb.Sheets(1).Range("a1:h" & wb.Sheets(1).[c65536].End(3).Row)
   
8.     wb.Close False
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     Set d1 = CreateObject("scripting.dictionary")
    
11.     For i = 2 To UBound(arr)
    
12.         x = arr(i, 3)
    
13.         If Len(x) > 0 Then
    
14.             d(x) = ""
    
15.             y = arr(i, 8)
    
16.             If IsDate(y) Then
    
17.                 y = Year(y) & "年" & Month(y) & "月"
    
18.                 d1(x & y) = d1(x & y) + 1
    
19.             End If
    
20.         End If
    
21.     Next
    
22.     With ActiveSheet
    
23.         .[a6].Resize(1000, 200) = ""
    
24.         .[a6].Resize(d.Count) = Application.Transpose(d.keys)
    
25.         cmax = .Cells(5, 256).End(xlToLeft).Column
    
26.         arr = .[a4].Resize(d.Count + 2, cmax)
    
27.         For j = 2 To cmax
    
28.             If arr(1, j) = "" Then arr(1, j) = arr(1, j - 1)
    
29.         Next
    
30.         For i = 3 To UBound(arr)
    
31.             s = 0
    
32.             For j = 2 To cmax
    
33.                 xkey = arr(i, 1) & arr(1, j) & arr(2, j)
    
34.                 arr(i, j) = d1(xkey)
    
35.                 s = s + d1(xkey)
    
36.             Next
    
37.             If s = 0 Then arr(i, 1) = ""
    
38.         Next
    
39.         .[a4].Resize(d.Count + 2, cmax) = arr
    
40.         .Range("a5").Resize(d.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete   '删除无数据的行
    
41.     End With
    
42. End Sub

复制代码

王英wang

grf1973 发表于 2017-1-23 09:54

非常感谢老师的帮助，还有一个问题，就是如何将一年以上未使用的料号提取到另一个表格，谢谢。

grf1973

1. Sub 一年以上未使用()
   
2.     r = [a65536].End(3).Row
   
3.     c = [iv5].End(xlToLeft).Column
   
4.     arr = [a1].Resize(r, c)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For j = 2 To c
   
7.         If arr(4, j) = "" Then arr(4, j) = arr(4, j - 1)
   
8.     Next
   
9.     For i = 6 To r
   
10.         For j = 2 To c - 1
    
11.             If arr(i, j) = "" Then
    
12.                 s1 = arr(4, j) & arr(5, j) '起始年月
    
13.                 n = 1
    
14.                 For jj = j + 1 To c
    
15.                     If arr(i, jj) = "" Then n = n + 1
    
16.                     If arr(i, jj) <> "" Or jj = c Then
    
17.                         If n >= 12 Then
    
18.                             s2 = arr(4, jj) & arr(5, jj) '结束年月
    
19.                             d(arr(i, 1)) = s1 & "-" & s2 & "：共" & n & "个月"
    
20.                             GoTo nexti
    
21.                         Else
    
22.                             j = jj
    
23.                             Exit For
    
24.                         End If
    
25.                     End If
    
26.                 Next
    
27.             End If
    
28.         Next j
    
29. nexti:    Next i
    
30.     If d.Count > 0 Then Sheets(2).[a1].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    
31.                
    
32. End Sub

复制代码

王英wang

grf1973 发表于 2017-2-8 15:00

非常感谢老师的帮助，可能是我描述的有问题，想要的结果是”从当前月份到最后一次出现的月份超过12个月的提取”
比如（08-E00576 从2017年2月最后一次出现是2015年11月）
红色部分不需要提取
想要的结果是黄色部分

只需要提取黄色部分

grf1973

1. Sub 一年以上未使用()
   
2.     r = [a65536].End(3).Row
   
3.     c = [iv5].End(xlToLeft).Column
   
4.     arr = [a1].Resize(r, c)
   
5.     ReDim brr(1 To UBound(arr), 1 To 2)
   
6.     For j = 2 To c
   
7.         If arr(4, j) = "" Then arr(4, j) = arr(4, j - 1)
   
8.     Next
   
9.     s2 = arr(4, c) & arr(5, c) '结束年月
   
10.     For i = 6 To r
    
11.         j = c: n = 0
    
12.         Do While arr(i, j) = ""
    
13.             n = n + 1
    
14.             j = j - 1
    
15.         Loop
    
16.         If n >= 12 Then
    
17.             p = p + 1
    
18.             s1 = arr(4, j + 1) & arr(5, j + 1) '结束年月
    
19.             brr(p, 1) = arr(i, 1)
    
20.             brr(p, 2) = s1 & "-" & s2 & "：共" & n & "个月"
    
21.         End If
    
22.     Next
    
23.     If p > 0 Then
    
24.         With Sheets(2)
    
25.             .Cells.ClearContents
    
26.             .[a1].Resize(p, 2) = brr
    
27.             .Activate
    
28.         End With
    
29.     Else
    
30.         MsgBox "无一年以上未使用的零件"
    
31.     End If
    
32. End Sub

复制代码

王英wang

grf1973 发表于 2017-2-9 10:21

非常感谢帮助，老师太厉害。

王英wang

grf1973 发表于 2017-1-23 09:54

帮忙看看改一下efpr表格的代码，（把工作薄2数据表格C列对应E列“DA/WB“）写到efpr表格的B列，谢谢

雄鹰2013

Sub 一年以上未使用的材料()
Dim arr
arr = Sheet1.Range("a4:al" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 2)
For j = 2 To UBound(arr, 2)
     If arr(1, j) = "" Then arr(1, j) = arr(1, j - 1)
Next j
For i = 3 To UBound(arr)
     k = 0
     For j = 2 To UBound(arr, 2)
         Do While arr(i, j) = ""
            k = k + 1
            If k = 1 Then
               qr = arr(1, j) & arr(2, j)
               qy = Val(arr(2, j)) '起始日期
            End If
            j = j + 1
            If j > UBound(arr, 2) Then Exit Do
         Loop
         If k >= 12 Then
            n = n + 1
            j = j - 1
            zr = arr(1, j) & arr(2, j)   '终止日期
            brr(n, 1) = arr(i, 1)
            brr(n, 2) = qr & "-" & zr & "：共" & k & "个月"
            qr = "": zr = ""
            Exit For
         Else
            qr = "": k = 0
         End If
     Next j
Next i
Sheet2.Columns("d:e").Clear
Sheet2.[d1].Resize(n, 2) = brr
End Sub