根据excel中的明细表，生成出入库单

160636

根据excel中的明细表，自动按日期和客户分类（不要汇总），生成出入库单（一张出入库单明细不超10行，超10行自动生成另一张），并可以连续打印。哪位大神伸下援手，不胜感激！

鄂龙蒙

明细表怎么能看出是入库或出库呢

160636

鄂龙蒙 发表于 2019-7-7 14:36
明细表怎么能看出是入库或出库呢

其实不用管出入库，主要是按日期和客户分类，生成表单打印

160636

鄂龙蒙 发表于 2019-7-7 14:36
明细表怎么能看出是入库或出库呢

留言板上的，加你了，可以通过一下吗

一把小刀闯天下

'数量、金额给你合计了一下。大小写这论坛找了一个函数给你套用了一下估计差不多

'行高以输出表格的1-16行行高为基准设置的

'"出入库单能不能跟着更新"没看到条件自己处理一下吧，应该没什么难度的吧，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, a, b, m, cnt, p, sum1, sum2
  Application.ScreenUpdating = False
  Sheets("出入库单").Activate
  [a17].Resize(10 ^ 4, 6).Clear
  arr = Sheets("出入库明细").[a1].CurrentRegion.Offset(1).Resize(, 8)
  Call dsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 1) <> arr(j + 1, 1) Then
        Call dsort(arr, i, j, 1, UBound(arr, 2), 2)
        p = i
        For k = i To j
          If arr(k, 1) <> arr(k + 1, 1) Or arr(k, 2) <> arr(k + 1, 2) Then
            ReDim brr(1 To 10, 1 To 6)
            For a = p To k
              m = m + 1
              sum1 = sum1 + arr(a, 5)
              sum2 = sum2 + arr(a, 7)
              For b = 3 To 8
                brr(m, b - 2) = arr(a, b)
              Next
              If m = 10 Then
                Rows(1).Resize(16).Copy Rows(cnt + 1)
                Cells(cnt + 2, "b") = arr(a, 2)
                Cells(cnt + 2, "e") = arr(a, 1)
                Cells(cnt + 14, "c") = sum1
                Cells(cnt + 14, "e") = sum2
                Cells(cnt + 15, "b") = RMBcase(sum2)
                Cells(cnt + 4, "a").Resize(10, 6) = brr
                cnt = cnt + 16: m = 0: sum1 = 0: sum2 = 0
                ReDim brr(1 To 10, 1 To 6)
              End If
            Next
            If m > 0 Then
              Rows(1).Resize(16).Copy Rows(cnt + 1)
              Cells(cnt + 2, "b") = arr(a - 1, 2)
              Cells(cnt + 2, "e") = arr(a - 1, 1)
              Cells(cnt + 14, "c") = sum1
              Cells(cnt + 14, "e") = sum2
              Cells(cnt + 15, "b") = RMBcase(sum2)
              Cells(cnt + 4, "a").Resize(10, 6) = brr
              cnt = cnt + 16
            End If
            p = k + 1: m = 0: sum1 = 0: sum2 = 0
          End If
        Next
        i = j: Exit For
      End If
    Next
  Next
  Application.ScreenUpdating = True
End Sub

Function dsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) > arr(j, key) Then
        For k = left To right
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function

Function RMBcase(Num) As String
  Dim s As String, i As Long
  s = Replace(Replace(Application.Text(Format(Num, "0.00"), "[DBNum2]"), "-", "负"), ".", "元"): i = Len(s)
  Select Case InStr(1, s, "元", 1)
  Case 0: If s = "零" Then s = "" Else s = s & "元整"
  Case i - 1: s = s & "角整"
  Case i - 2: s = left(s, i - 1) & "角" & right(s, 1) & "分"
  End Select: RMBcase = Replace(Replace(Replace(s, "零元零角", ""), "零元", ""), "零角", "零")
End Function

160636

一把小刀闯天下 发表于 2019-7-7 15:16
Option Explicit

Sub test()

大神，更新明细资料后，出入库单有办法刷新吗？出入库单的行高，能不能固定。每一张出入库单的数量和金额合计数能出来吗？还有大写金额也要

160636

一把小刀闯天下 发表于 2019-7-7 15:16
Option Explicit

Sub test()

大神，明细表中的数据更新后，出入库单能不能跟着更新，合计栏中的数量和金额能不能合计出来，大写金额栏也能显示出大写金额。出入库单的行高能不能固定一下。谢谢大神了

一把小刀闯天下

160636 发表于 2019-7-7 18:06
大神，明细表中的数据更新后，出入库单能不能跟着更新，合计栏中的数量和金额能不能合计出来，大写金额栏 ...

5楼已更新。输出表格的1-16行表格自己好好设置一下，因为它是基准表格，行高等都是以它为模板的
尽量不要去使用自动更新，因为对于你这问题来说毫无意义，，，

chxw68

1. Sub test()
   
2.   Dim r%, i%, m%
   
3.   Dim arr, brr, hg(1 To 17)
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("出入库明细")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a2:h" & r)
    
11.   End With
    
12.   For i = 1 To UBound(arr)
    
13.     If Not d.exists(arr(i, 1)) Then
    
14.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.     End If
    
16.     If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
17.       m = 1
    
18.       ReDim brr(1 To 6, 1 To m)
    
19.     Else
    
20.       brr = d(arr(i, 1))(arr(i, 2))
    
21.       m = UBound(brr, 2) + 1
    
22.       ReDim Preserve brr(1 To 6, 1 To m)
    
23.     End If
    
24.     For j = 1 To 6
    
25.       brr(j, m) = arr(i, j + 2)
    
26.     Next
    
27.     d(arr(i, 1))(arr(i, 2)) = brr
    
28.   Next
    
29.   q = 18
    
30.   With Worksheets("出入库单")
    
31.     For i = 1 To 17
    
32.       hg(i) = .Rows(i).RowHeight
    
33.     Next
    
34.     .Rows("18:" & .Rows.Count).Clear
    
35.     .Range("b2,e2,a4:f13,c14:f14") = ""
    
36.     .Range("c14,e14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    
37.     .Range("d14").FormulaR1C1 = "=R[-1]C"
    
38.     .Range("a15").FormulaR1C1 = "=""大写金额："" & dx(R[-1]C5)"
    
39.     For Each aa In d.keys
    
40.       For Each bb In d(aa).keys
    
41.         brr = d(aa)(bb)
    
42.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
43.         For i = 1 To UBound(brr)
    
44.           For j = 1 To UBound(brr, 2)
    
45.             crr(j, i) = brr(i, j)
    
46.           Next
    
47.         Next
    
48.         m = 4
    
49.         For i = 1 To UBound(crr)
    
50.           For j = 1 To UBound(crr, 2)
    
51.             .Cells(m, j) = crr(i, j)
    
52.           Next
    
53.           If m = 4 Then
    
54.             .Range("b2") = bb
    
55.             .Range("e2") = aa
    
56.           End If
    
57.           m = m + 1
    
58.           If m > 13 Or i = UBound(crr) Then
    
59.             .Range("a1:f16").Copy .Cells(q, 1)
    
60.             For w = 1 To 17
    
61.               .Rows(q + w - 1).RowHeight = hg(w)
    
62.             Next
    
63.             m = 4
    
64.             q = q + 17
    
65.           End If
    
66.         Next
    
67.       Next
    
68.     Next
    
69.     .Rows("1:17").Delete
    
70.   End With
    
71.          
    
72.         
    
73. End Sub
    

复制代码

chxw68

详见附件。