打印本票自动汇总信息到明细表

llizhen

每次打印后自动将信息填到明细表中

Chip_Kenny

1. Private Sub Workbook_BeforePrint(Cancel As Boolean)
   
2. Dim a, r&
   
3. With Sheets(1)
   
4.     a = Array(.[b9], .[f5], .[c5], .[e3], .[b10], .[j6])
   
5. End With
   
6. With Sheets(2)
   
7.     r = .[a1048576].End(3).Row + 1
   
8.     .Cells(r, 1)(1, 2).Resize(1, 6) = a
   
9.     .Cells(r, 1) = r - 1
   
10. End With
    
11. End Sub

复制代码

llizhen

Chip_Kenny 发表于 2018-7-14 12:31

请帮忙看看是什么原因？谢谢！

Chip_Kenny

放在ThisWorkbook中, 如附件

1. Private Sub Workbook_BeforePrint(Cancel As Boolean)
   
2. Dim a, r&, s(4) As String
   
3. s(0) = ActiveSheet.Name: s(1) = "澳門幣": s(2) = "明細清單-MOP": s(3) = "香港幣": s(4) = "明細清單-HKD"
   
4. If InStr(s(1) & s(3), s(0)) Then
   
5.     For i = 1 To 4
   
6.         If s(0) = s(i) Then Exit For
   
7.     Next
   
8.     With Sheets(s(i + 1))
   
9.         r = .[a1048576].End(3).Row + 1
   
10.         a = Array(r - 1, [b9], [f5], [c5], [e3], [b10], [j6])
    
11.         .Cells(r, 1).Resize(1, 7) = a
    
12.     End With
    
13. End If
    
14. End Sub

复制代码

Chip_Kenny

多說一聲, 不用加按鈕

llizhen

Chip_Kenny 发表于 2018-7-16 12:33
多說一聲, 不用加按鈕

謝謝你的幫忙 ，可是在打印澳門幣之後會自動存档，但港币是不行的

Chip_Kenny

檢查所有頁名是否跟代碼的頁名是一致, 無論是空格或甚麼的, 或直接下載給提供的附件。

llizhen

Chip_Kenny 发表于 2018-7-16 15:46
檢查所有頁名是否跟代碼的頁名是一致, 無論是空格或甚麼的, 或直接下載給提供的附件。

好的，謝謝！

hasyh2008

如果两行一样，将自动删除！
Private Sub Workbook_BeforePrint(Cancel As Boolean)
     Dim Rown As Long, i As Long, arr1, arr2
        Rown = Sheet2.Range("B" & Rows.Count).End(xlUp).Row + 1

        Sheet1.Range("B9").Copy Sheet2.Range("B" & Rown)
        Sheet1.Range("C5").Copy Sheet2.Range("C" & Rown)
        Sheet1.Range("F5").Copy Sheet2.Range("D" & Rown)
        Sheet1.Range("E3").Copy Sheet2.Range("E" & Rown)
        Sheet1.Range("B10").Copy Sheet2.Range("F" & Rown)
        Sheet1.Range("J6").Copy Sheet2.Range("G" & Rown)

        For i = 1 To Rown - 1
            Sheet2.Range("A" & i + 1) = i
        Next i

        arr1 = Sheet2.Range("B" & Rown & ":G" & Rown).Value
        arr2 = Sheet2.Range("B" & Rown - 1 & ":G" & Rown - 1).Value

        If arr1(1, 1) = arr2(1, 1) And arr1(1, 2) = arr2(1, 2) And arr1(1, 3) = arr2(1, 3) And arr1(1, 4) = arr2(1, 4) And arr1(1, 5) = arr2(1, 5) And arr1(1, 6) = arr2(1, 6) Then
            Sheet2.Range("B" & Rown).EntireRow.Delete
        End If
End Sub