出入库统计增加上年库存统计并按名称排序

jaxpqh

　　我有一个《出入库明细》的工作表，我自己设计了出入库统计的VBA代码，目前能实现当年的库存统计，上年的库存数据统计不了，自己也不知道怎么改，请哪位大师帮我改一改代码，实现我期望的功能，并且帮我按名称排序。在此先说声谢谢！

liulang0808

Sub 出入库明细()
    Dim r%, i%, c%, j%, m%, k%
    Dim arr, brr, crr, brr1, crr1, drr, sm
    Dim rq As Date
    Dim d As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    lk = Array(20, 8, 8, 8)
    Set d = CreateObject("scripting.dictionary")
    nf = Application.InputBox(prompt:="请输入统计年份", Title:="操作提示", Default:=Year(Date), Type:=1)
    If TypeName(nf) = "Boolean" Then
        Exit Sub
    End If
    tt = Timer
    With ThisWorkbook.Worksheets("出入库明细")
        .AutoFilterMode = False
        r = .Cells(.Rows.Count, 3).End(xlUp).Row
        c = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range("a2").Resize(r - 1, c)
    End With
    ReDim brr(1 To UBound(arr), 1 To 5)
    For i = 1 To UBound(arr)

        If arr(i, 3) <> "" Then
            s = arr(i, 3)
            If Not d.exists(s) Then
               m = m + 1
               d(s) = m
               brr(m, 1) = arr(i, 3)
            End If
            If Year(arr(i, 1)) = nf Then
               brr(d(s), 3) = brr(d(s), 3) + arr(i, 7)
               brr(d(s), 4) = brr(d(s), 4) + arr(i, 8)
               brr(d(s), 5) = brr(d(s), 5) + arr(i, 7) - arr(i, 8)
            Else
                brr(d(s), 2) = brr(d(s), 2) + arr(i, 7) - arr(i, 8)
            End If
        End If

    Next
    If d.Count = 0 Then
        MsgBox "没有符合条件数据！"
        Exit Sub
    End If
    With ThisWorkbook.Worksheets("库存汇总表")
        .Range("a3").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 52).Clear
        With .Range("a3").Resize(m, 5)
            .Value = brr
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter   ' 单元格居中
            With .Font
                .Name = "times new roman"
                .Size = 12
            End With
        End With
        With .Cells(m + 3, 1)
            .Value = "合计"
        End With
        For x = 2 To 5
            With .Cells(m + 3, x)
                 .Value = Application.Sum(Application.Index(brr, 0, x))
            End With
        Next x
        With .Range(.Cells(m + 3, 1), .Cells(m + 3, 5))
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter ' 单元格居中
            With .Font
                .Name = "times new roman"
                .Size = 12
                .Bold = True
            End With
            .Interior.Color = 11389944
        End With
        With .Range("b3").Resize(m + 1, 4)
            .NumberFormat = "0_  "     '设置单元格数字格式
            .HorizontalAlignment = xlRight  ' 单元格居右
        End With
        With .Cells(4 + m, 2).Resize(1)
            .Value = "上次统计时间：" & Format(Date, "yyyy年m月d日")
            With .Font
              .Name = "times new roman"
              .Size = 12
            End With
        End With
    End With
End Sub

liulang0808

在楼主的源代码基础上做了调整
看看是否符合要求，另外还可以进一步优化的

loirol

这代码是你自己写的不会改？多定义一个字典去统计year(arr(i,1))<>nf的数据不就完了

yanglinzi

arr(i,1)<nf 就是上年数据

jaxpqh

liulang0808 发表于 2024-10-28 13:46
在楼主的源代码基础上做了调整
看看是否符合要求，另外还可以进一步优化的

　　不好意思，实际上本年库存的数据想要的是累计库存的数据，是我开始没有说清楚，所以你的代码没有加上上年的库存数据。我在你的代码基础上作了改动，把上年库存条件改为“< nf ”，因为大于输入框年份的数据不做统计，而且我把累计库存的数据直接由“上年库存+入库-出库”即“列2+列3-列4”，但得出的结果不正确，不知哪里代码出了问题，请您帮我看看错在哪里，谢谢了！还有就是想按名称进行排序，我不会弄，请您一并看看。

liulang0808

改了下，看看是否合适？

leeson0219

参与一下，用SQL，只做了包含上年库存的。

1. Sub mySum()
   
2.     Dim sql1 As String, sql2 As String, sql3 As String, sql As String, tbl As String, dbs As String
   
3.     Dim ws As Worksheet, rng As Range
   
4.     Dim conn As Object, rs As Object, strConn As String
   
5.     Dim currYear As Integer
   
6.     On Error Resume Next
   
7.     currYear = InputBox("请输入查询年份：", "输入", Year(Date))
   
8.     dbs = ThisWorkbook.FullName
   
9.     tbl = "[出入库明细$]"
   
10.     Set conn = CreateObject("ADODB.Connection")
    
11.     Set rs = CreateObject("ADODB.Recordset")
    
12.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & dbs
    
13.    
    
14.     sql1 = "select 名称,(sum(入库)-sum(出库)) as 上年库存 from " & tbl & " where year(日期)< " & currYear & " group by 名称"
    
15.     sql2 = "select 名称,sum(入库) as 入库,sum(出库) as 出库, (sum(入库)-sum(出库)) as 本年库存 from " & tbl & " where year(日期)<= " & currYear & " group by 名称"
    
16.     sql = "select b.名称, a.上年库存,b.入库,b.出库,b.本年库存 from (" & sql2 & ") as b left join (" & sql1 & ") as a on a.名称=b.名称"
    
17.     sql3 = "select  '合计' AS 名称, sum(上年库存) as 上年库存 , sum(入库) as 入库 ,sum(出库) as 出库  , sum(本年库存) as 本年库存 from (" & sql & ")"
    
18.     sql = sql & " union all " & sql3
    
19.    
    
20.     conn.Open strConn
    
21.     rs.CursorType = 3
    
22.     rs.Open sql, conn
    
23.     Set ws = ThisWorkbook.Sheets("库存汇总表")
    
24.     With ws
    
25.         .Range("F3").Resize(.UsedRange.Rows.Count - 2, 5).Cells.Clear
    
26.         Set rng = .Range("F3").Resize(rs.RecordCount, 5)
    
27.         With rng
    
28.             .CopyFromRecordset rs
    
29.             .Columns(1).HorizontalAlignment = xlCenter
    
30.             .Borders.LineStyle = 1
    
31.             .Rows(.Rows.Count).Interior.Color = RGB(255, 160, 122)
    
32.             .Rows(.Rows.Count).Font.Bold = True
    
33.             .Cells(.Rows.Count, 3).Offset(1) = "上次统计时间：" & Format(Date, "yyyy年m月d日")
    
34.         End With
    
35.     End With
    
36.     rs.Close
    
37.     conn.Close
    
38.     Set rs = Nothing
    
39.     Set conn = Nothing
    
40.     MsgBox "Done!"
    
41. End Sub
    

复制代码

jaxpqh

liulang0808 发表于 2024-10-28 18:53
改了下，看看是否合适？

　　您好，库存统计正合我意，我还想按名称进行排序，这样方便查找，因为实际工作中的名称比较多。我自己用录制宏的方式加入了排序的代码，但没有达到我想要的结果，因为它并没有对库存这个表进行排序，而是对原始数据的明细表进行了排序。我不知道问题出在哪里，请您帮我看看，并帮我改正。谢谢了！

liulang0808

Sub 出入库明细()
    Dim r%, i%, c%, j%, m%, k%
    Dim arr, brr, crr, brr1, crr1, drr, sm
    Dim rq As Date
    Dim d As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    lk = Array(20, 8, 8, 8)
    Set d = CreateObject("scripting.dictionary")
    nf = Application.InputBox(prompt:="请输入统计年份", Title:="操作提示", Default:=Year(Date), Type:=1)
    If TypeName(nf) = "Boolean" Then
        Exit Sub
    End If
    tt = Timer
    With ThisWorkbook.Worksheets("出入库明细")
        .AutoFilterMode = False
        r = .Cells(.Rows.Count, 3).End(xlUp).Row
        c = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range("a2").Resize(r - 1, c)
    End With
    ReDim brr(1 To UBound(arr), 1 To 5)
    For i = 1 To UBound(arr)

        If arr(i, 3) <> "" Then
            s = arr(i, 3)
            If Not d.exists(s) Then
               m = m + 1
               d(s) = m
               brr(m, 1) = arr(i, 3)
            End If
            If Year(arr(i, 1)) < nf Then
               brr(d(s), 2) = brr(d(s), 2) + arr(i, 7) - arr(i, 8)
            End If
            If Year(arr(i, 1)) = nf Then
               brr(d(s), 3) = brr(d(s), 3) + arr(i, 7)
               brr(d(s), 4) = brr(d(s), 4) + arr(i, 8)
            End If
            brr(d(s), 5) = brr(d(s), 5) + arr(i, 7) - arr(i, 8)
        End If

    Next
    If d.Count = 0 Then
        MsgBox "没有符合条件数据！"
        Exit Sub
    End If
    With ThisWorkbook.Worksheets("库存汇总表")
        .Range("a3").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 52).Clear
        With .Range("a3").Resize(m, 5)
            .Value = brr
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter   ' 单元格居中
            With .Font
                .Name = "times new roman"
                .Size = 12
            End With
        End With
        With .Cells(m + 3, 1)
            .Value = "合计"
        End With
        For x = 2 To 5
            With .Cells(m + 3, x)
                 .Value = Application.Sum(Application.Index(brr, 0, x))
            End With
        Next x
        With .Range(.Cells(m + 3, 1), .Cells(m + 3, 5))
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter ' 单元格居中
            With .Font
                .Name = "times new roman"
                .Size = 12
                .Bold = True
            End With
            .Interior.Color = 11389944
        End With
        With .Range("b3").Resize(m + 1, 4)
            .NumberFormat = "0_  "     '设置单元格数字格式
            .HorizontalAlignment = xlRight  ' 单元格居右
        End With
        With .Cells(4 + m, 2).Resize(1)
            .Value = "上次统计时间：" & Format(Date, "yyyy年m月d日")
            With .Font
              .Name = "times new roman"
              .Size = 12
            End With
        End With
            
                    
    End With
    r = m + 2
    ActiveWorkbook.Worksheets("库存汇总表").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("库存汇总表").Sort.SortFields.Add Key:=Range("A3:A" & r), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("库存汇总表").Sort
        .SetRange Range("A3:E" & r)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub