统计数据

木木的小二樂

根据台账表统计另外两个表之间的数据，谢谢各位老师


补充：感谢各位了老师，我的疏忽，没有说明白，A列日期是个引导，如输入20221205在A列，那么出库是20221205的当日数据，累计是20221205所在的sheet里面的整列数据（如P.42的累计就是工作表2022.12中P.42整列的数据和），其它同理。

LIUZHU

这个题目的要求有点没看明白，到底是提取所有日期的出库记录，还是给定一些具体的日期，然后提取这些日期对应的出库记录？

mmwwdd

你可够简洁的了，不明白你的意思

mmwwdd

现在发帖子的人都很有意思，直接发了，让人猜

木木的小二樂

LIUZHU 发表于 2022-12-22 00:00
这个题目的要求有点没看明白，到底是提取所有日期的出库记录，还是给定一些具体的日期，然后提取这些日期对 ...

哎，我前面不是举例了三个例子嘛，旁边的右边我还说明了一下

如20221222，就提取这个日期的出库和这个日期往上的累计，累计是一个sheet里面的

木木的小二樂

mmwwdd 发表于 2022-12-22 06:02
现在发帖子的人都很有意思，直接发了，让人猜

很抱歉，我写了几个例子，然后旁边的右边也写了部分说明，我以为能理解了，因为表1和表2数据并不多，联想一下，我以为可以理解

chzsh

Sub Macro1()
    Dim MyPath$, MyName$, sh As Worksheet, arr
    MyPath = ThisWorkbook.Path & "\销售\"
    MyName = Dir(MyPath & "*.xls")
    Application.ScreenUpdating = False
j3 = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
ThisWorkbook.Sheets(1).Range("b6:b" & j3).ClearContents
ThisWorkbook.Sheets(1).Range("d6:d" & j3).ClearContents
ThisWorkbook.Sheets(1).Range("h6:h" & j3).ClearContents
ThisWorkbook.Sheets(1).Range("j6:j" & j3).ClearContents
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            Set wb = GetObject(MyPath & MyName)
      
           If wb.Name = "表1.xls" Then
                       For i = 2 To wb.Sheets.Count
                                 k = wb.Sheets(i).Range("i65536").End(xlUp).Row
                                m = wb.Sheets(1).Range("i65536").End(xlUp).Row
                                wb.Sheets(i).Range("a4:i" & k).Copy wb.Sheets(1).Range("a" & m + 1)
                                m = m + k - 3
                       Next
                       arr = wb.Sheets(1).Range("a4:i" & m)
                       Set d = CreateObject("scripting.dictionary")
                    For i = 1 To UBound(arr)
                           s = arr(i, 9)
                          If Not d.exists(s) Then
                            d(s) = Array(Val(arr(i, 4)), arr(i, 6))
                          Else
                            d(s) = Array(Val(arr(i, 4)) + d(s)(0), Val(arr(i, 6)) + d(s)(1))
                          End If
                    Next
                      k = d.keys
                      t = d.items
                    With ThisWorkbook
                    For j1 = 6 To j3
                       For j2 = 0 To d.Count - 1
                            If .Sheets(1).Range("a" & j1) = k(j2) Then
                                .Sheets(1).Range("b" & j1) = t(j2)
                                .Sheets(1).Range("d" & j1) = t(j2)(1)
                            End If
                       Next j2
                    Next j1
                 End With
          End If

      If wb.Name = "表2.xls" Then
                       For i = 2 To wb.Sheets.Count
                               k = wb.Sheets(i).Range("a65536").End(xlUp).Row
                                m = wb.Sheets(1).Range("a65536").End(xlUp).Row
                                wb.Sheets(i).Range("a4:j" & k).Copy wb.Sheets(1).Range("a" & m + 1)
                                m = m + k - 3
                       Next
                       arr = wb.Sheets(1).Range("a4:j" & m)
                       Set d = CreateObject("scripting.dictionary")
                    For i = 1 To UBound(arr)
                           s = arr(i, 1)
                          If Not d.exists(s) Then
                            d(s) = Array(Val(arr(i, 4)), arr(i, 5))
                          Else
                            d(s) = Array(Val(arr(i, 4)) + d(s)(0), Val(arr(i, 5)) + d(s)(1))
                          End If
                    Next
                      k = d.keys
                      t = d.items
                    With ThisWorkbook
                    For j1 = 6 To j3
                       For j2 = 0 To d.Count - 1
                            If .Sheets(1).Range("a" & j1) = k(j2) Then
                                .Sheets(1).Range("h" & j1) = t(j2)
                                .Sheets(1).Range("j" & j1) = t(j2)(1)
                            End If
                       Next j2
                    Next j1
                 End With     
          End If
         
   
     wb.Close False
        MyName = Dir
    End If
    Loop
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub