按四个时间维度，根据唯一编码抓取数据。

w01013086

求大神，用VBA，帮忙根据唯一编码，抓取年、月、周、日，四个维度的数据，选年度，点查询时，统计年度的数据 ，选周期，点查询时，抓取周期的数据，都是要最新日期的。

fzxba

一看，需求不少……

阿白124

这就是一个耗时的事情，这么多需求，谁闲谁搞，白嫖搞起来浪费时间。

3190496160

不要指望在论坛能够得到义务解决，

fzxba

1. Sub test1()
   
2.   Dim ar, br() As Double, Dict As Object, s As String
   
3.   Dim i As Long, j As Integer, x As Integer, y As Long
   
4.   Dim iYear As Integer
   
5.   
   
6.   Sheet1.Activate
   
7.   
   
8.   Set Dict = CreateObject("Scripting.Dictionary")
   
9.   ar = Range("C3", Cells(Rows.Count, "C").End(xlUp)).Value
   
10.   For i = 1 To UBound(ar)
    
11.     s = Trim(ar(i, 1))
    
12.     If Len(s) Then Dict.Add s, i
    
13.   Next
    
14.   ReDim br(1 To UBound(ar), 1 To 7)
    
15.   iYear = Val(Range("L1").Value)  '查询条件为年，其余自行变通
    
16.   
    
17.   x = 1
    
18.   With Sheet2
    
19.     ar = .Range("D2:K" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value
    
20.   End With
    
21.   For i = 1 To UBound(ar)
    
22.     If Year(Split(ar(i, 1), Space(1))(0)) = iYear Then ' 变通
    
23.       s = Trim(ar(i, 4))
    
24.       If Dict.Exists(s) Then
    
25.         y = Dict(s)
    
26.         br(y, x) = br(y, x) + Val(ar(i, 8))
    
27.       End If
    
28.     End If
    
29.   Next
    
30.   
    
31.   x = 2
    
32.   With Sheet3
    
33.     ar = .Range("D2:J" & .Cells(.Rows.Count, "J").End(xlUp).Row).Value
    
34.   End With
    
35.   For i = 1 To UBound(ar)
    
36.     If Year(ar(i, 1)) = iYear Then ' 变通
    
37.       s = Trim(ar(i, 2))
    
38.       If Dict.Exists(s) Then
    
39.         y = Dict(s)
    
40.         br(y, x) = br(y, x) + Val(ar(i, 7))
    
41.       End If
    
42.     End If
    
43.   Next
    
44.   
    
45.   x = 3
    
46.   With Sheet4
    
47.     ar = .Range("C2:AF" & .Cells(.Rows.Count, "AF").End(xlUp).Row).Value
    
48.   End With
    
49.   For i = 1 To UBound(ar)
    
50.     If Year(ar(i, 30)) = iYear Then ' 变通
    
51.       s = Trim(ar(i, 5))
    
52.       If Dict.Exists(s) Then
    
53.         y = Dict(s)
    
54.         br(y, x) = br(y, x) + Val(ar(i, 9))
    
55.         j = 2 + (ar(i, 1) = "天猫")
    
56.         br(y, x + j) = br(y, x + j) + Val(ar(i, 9))
    
57.       End If
    
58.     End If
    
59.   Next
    
60.   
    
61.   x = 6
    
62.   With Sheet5
    
63.     ar = .Range("A2:W" & .Cells(.Rows.Count, "W").End(xlUp).Row).Value
    
64.   End With
    
65.   For i = 1 To UBound(ar)
    
66.     If Year(ar(i, 1)) = iYear Then ' 变通
    
67.       s = Trim(ar(i, 3))
    
68.       If Dict.Exists(s) Then
    
69.         y = Dict(s)
    
70.         j = 1 + (ar(i, 23) = "天猫")
    
71.         br(y, x + j) = br(y, x + j) + Val(ar(i, 17))
    
72.       End If
    
73.     End If
    
74.   Next
    
75.   
    
76.   Range("K3").Resize(UBound(br), UBound(br, 2)) = br
    
77.   
    
78.   Set Dict = Nothing
    
79.   Beep
    
80. End Sub

复制代码

3190496160

Private Sub CommandButton1_Click()
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
If OptionButton1.Value = False And OptionButton2.Value = False And OptionButton3.Value = False And OptionButton4.Value = False Then MsgBox "请选择查询选项！": Exit Sub
If TextBox1.Text = "" And TextBox2.Text = "" And TextBox3.Text = "" And TextBox2.Text = "" Then MsgBox "请输入查询条件！": Exit Sub
With Sheets("入库明细")
    r1 = .Cells(Rows.Count, 7).End(xlUp).Row
    ar1 = .Range("a1:l" & r1)
End With
With Sheets("每日库存结余")
    r2 = .Cells(Rows.Count, 5).End(xlUp).Row
    ar2 = .Range("a1:j" & r2)
End With
With Sheets("出库明细")
    r3 = .Cells(Rows.Count, 7).End(xlUp).Row
    ar3 = .Range("a1:bi" & r3)
End With
With Sheets("退货明细")
    r4 = .Cells(Rows.Count, 3).End(xlUp).Row
    ar4 = .Range("a1:ay" & r4)
End With
With Sheets("订单总台账")
    r = .Cells(Rows.Count, 3).End(xlUp).Row
     .Range("d3:q" & r) = Empty
    ar = .Range("a2:q" & r)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 3)) <> "" Then
            d(Trim(ar(i, 3))) = i
        End If
    Next i
    If OptionButton1.Value = True Then
        tj = TextBox1.Text
    ElseIf OptionButton2.Value = True Then
        tj = TextBox2.Text
    ElseIf OptionButton3.Value = True Then
        tj = TextBox3.Text
    ElseIf OptionButton4.Value = True Then
        tj = TextBox4.Text
    End If
        For i = 2 To UBound(ar1)
            If Trim(ar1(i, 7)) <> "" Then
                xh = d(Trim(ar1(i, 7)))
                If xh <> "" Then
                    If Trim(ar1(i, 4)) <> "" Then
                        If IsDate(ar1(i, 4)) Then
                            If OptionButton1.Value = True Then
                                rqq = DatePart("ww", rq)
                            ElseIf OptionButton2.Value = True Then
                                rqq = Year(rq)
                            ElseIf OptionButton3.Value = True Then
                                rqq = Month(rq)
                            ElseIf OptionButton4.Value = True Then
                                rqq = Format(ar1(i, 4), "yyyy/m/d")
                            End If
                            If rqq = tj Then
                                ar(xh, 11) = ar(xh, 11) + ar1(i, 11)
                            End If
                        End If
                    End If
                End If
            End If
        Next i
        
        For i = 2 To UBound(ar2)
            If Trim(ar2(i, 5)) <> "" Then
                xh = d(Trim(ar2(i, 5)))
                If xh <> "" Then
                    If Trim(ar2(i, 4)) <> "" Then
                        If IsDate(ar2(i, 4)) Then
                            rq = Format(ar2(i, 4), "yyyy/m/d")
                            zc = DatePart("ww", rq)
                            ny = Year(rq)
                            yf = Month(rq)
                            rq = rq
                            If zc = tj Then
                                ar(xh, 12) = ar2(i, 12)
                            End If
                        End If
                    End If
                End If
            End If
        Next i
   
        For i = 2 To UBound(ar3)
            If Trim(ar3(i, 7)) <> "" Then
                xh = d(Trim(ar3(i, 7)))
                If xh <> "" Then
                    If Trim(ar3(i, 32)) <> "" Then
                        If IsDate(ar3(i, 32)) Then
                            rq = Format(ar3(i, 32), "yyyy/m/d")
                            zc = DatePart("ww", rq)
                            ny = Year(rq)
                            yf = Month(rq)
                            rq = rq
                            If zc = tj Then
                                If Trim(ar3(i, 3)) = "天猫" Then
                                    ar(xh, 14) = ar(xh, 14) + ar3(i, 11)
                                Else
                                    ar(xh, 15) = ar(xh, 15) + ar3(i, 11)
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        Next i
   
        For i = 2 To UBound(ar4)
            If Trim(ar4(i, 3)) <> "" Then
                xh = d(Trim(ar4(i, 3)))
                If xh <> "" Then
                    If Trim(ar4(i, 1)) <> "" Then
                        If IsDate(ar4(i, 1)) Then
                            rq = Format(ar4(i, 1), "yyyy/m/d")
                            zc = DatePart("ww", rq)
                            ny = Year(rq)
                            yf = Month(rq)
                            rq = rq
                            If zc = tj Then
                                If Trim(ar4(i, 23)) = "天猫" Then
                                    ar(xh, 16) = ar(xh, 16) + ar4(i, 17)
                                Else
                                    ar(xh, 16) = ar(xh, 16) + ar4(i, 17)
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        Next i
        .Range("a2:q" & r) = ar
End With
MsgBox "ok!"
End Sub

Private Sub OptionButton1_Click()
If OptionButton1 = True Then
    Label1.Visible = True
    TextBox1.Visible = True
    Label2.Visible = False
    TextBox2.Visible = False
    Label3.Visible = False
    TextBox3.Visible = False
    Label4.Visible = False
    TextBox4.Visible = False
End If
End Sub
Private Sub OptionButton2_Click()
If OptionButton2 = True Then
    Label2.Visible = True
    TextBox2.Visible = True
    Label1.Visible = False
    TextBox1.Visible = False
    Label3.Visible = False
    TextBox3.Visible = False
    Label4.Visible = False
    TextBox4.Visible = False
End If
End Sub
Private Sub OptionButton3_Click()
If OptionButton3 = True Then
    Label3.Visible = True
    TextBox3.Visible = True
    Label1.Visible = False
    TextBox1.Visible = False
    Label2.Visible = False
    TextBox2.Visible = False
    Label4.Visible = False
    TextBox4.Visible = False
End If
End Sub
Private Sub OptionButton4_Click()
If OptionButton4 = True Then
    Label4.Visible = True
    TextBox4.Visible = True
    Label2.Visible = False
    TextBox2.Visible = False
    Label3.Visible = False
    TextBox3.Visible = False
    Label1.Visible = False
    TextBox1.Visible = False
End If
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
    Label1.Visible = False
    TextBox1.Visible = False
    Label2.Visible = False
    TextBox2.Visible = False
    Label3.Visible = False
    TextBox3.Visible = False
    Label4.Visible = False
    TextBox4.Visible = False
End Sub

3190496160

仅仅是提供一个解决问题的思路，供参考
按不同时间维度，统计数据.rar (55.16 KB, 下载次数: 9)

2022-12-2 13:30 上传

点击文件名下载附件

w01013086

fzxba 发表于 2022-11-30 16:40

大佬，这个程序在库存那里是求和的，需求是抓取最新日期的库存，另外退货的也不准，数量会少。