批量将序时账生成记账凭证

840205910 · 发表于 2016-3-15 15:46

840205910 · 发表于 2016-3-15 15:48

本帖最后由 840205910 于 2016-3-15 17:38 编辑

Private Sub CommandButton1_Click()
Set d = CreateObject("scripting.dictionary")
arr = Sheet4.UsedRange
r = Sheet2.[a65535].End(3).Row + 1

For i = 5 To UBound(arr)
If arr(i, 1) <> "" Then d(arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3) & "|" & arr(i, 4)) = ""
Next
k = d.Keys

For j = 0 To UBound(k)
ReDim brr(1 To UBound(arr), 1 To 5)
n = 0: jf = 0: df = 0: fd = 0
For i = 5 To UBound(arr)
  If arr(i, 1) <> "" And arr(i, 1) & "-" & arr(i, 2) & "-" & arr(i, 3) & "|" & arr(i, 4) = k(j) Then
n = n + 1
jf = jf + arr(i, 8)
df = df + arr(i, 9)
fd = fd + arr(i, 10)
For p = 1 To 5
brr(n, p) = arr(i, p + 4)
Next

End If
Next
Y = Application.RoundUp(n / 7, 0)
For q = 1 To Y
ReDim crr(1 To 7, 1 To 5)
Sheet3.Range("a1", "e12").Copy Sheet2.Range("a" & r)
For w = 1 To 7
For g = 1 To 5
If n >= (q - 1)*7 + w Then crr(w, g) = brr((q - 1) * 7 + w, g)
Next
Next
  Sheet2.Range("a" & r + 3).Resize(7, 5) = crr
Sheet2.Range("d" & r + 10) = jf
Sheet2.Range("e" & r + 10) = df
Sheet2.Range("b" & r + 10) = "合计：" & DX(df)
Sheet2.Range("a" & r + 10) = Sheet2.Range("a" & r + 10) & fd
Sheet2.Range("c" & r + 1) = "日期：" & Split(Split(k(j), "|")(0), "-")(0) & "年" & Split(Split(k(j), "|")(0), "-")(1) & "月" & Split(Split(k(j), "|")(0), "-")(2) & "日"
   Sheet2.Range("e" & r + 1) = "第" & Split(k(j), "|")(1) & "号" & Chr(10) & Format(q, "000") & "/" & Format(Y, "000")
  Erase crr
r = r + 12
Next
Erase brr
Next

End Sub

840205910 · 发表于 2016-3-16 18:01

操作acc的好代码.rar (73.86 KB, 下载次数: 290)

fbata · 发表于 2016-3-17 15:58

向老学习.谢谢！

fbata · 发表于 2016-3-17 16:00

向老师学习.谢谢！

840205910 · 发表于 2016-3-19 10:10

Sub 映射局域网目录()
Shell "NET USE S: \\192.168.1.64\YGCB /USER:ADMINISTRATOR 123456"
End Sub

840205910 · 发表于 2016-3-19 11:07

Sub Macro1()
Dim cnn As Object
Dim SQL As String
Dim arr
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider = Microsoft.Jet.Oledb.4.0;Extended Properties ='Excel 8.0;hdr=no';Data Source =" & ThisWorkbook.Path & "\源数据.xls"
SQL = "select * from [Sheet1$B8:J20]"
arr = cnn.Execute(SQL).GetRows
For i = 0 To UBound(arr, 2)
For j = 0 To UBound(arr)
Cells(i + 1, j + 1) = arr(j, i)
Next
Next
cnn.Close
Set cnn = Nothing
End Sub

840205910 · 发表于 2016-3-21 11:58

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim BACmdpopup As CommandBarPopup
With Application.CommandBars("Worksheet Menu Bar")
For Each BACmdpopup In .Controls
      If BACmdpopup.Caption = "BOM Express" Then
         BACmdpopup.Delete
      End If
Next BACmdpopup
End With
End Sub

Private Sub Workbook_Open()
Dim BACmdpopup As CommandBarPopup
With Application.CommandBars("Worksheet Menu Bar")
For Each BACmdpopup In .Controls
      If BACmdpopup.Caption = "BOM Express" Then Exit Sub
Next BACmdpopup
End With

  Set mybar = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:= _
      msoControlPopup, Temporary:=True)
Set myControl2 = mybar.Controls.Add(Type:=msoControlButton, Temporary:=True)
  With mybar
.Caption = "BOM Express"
End With
With myControl2
'.DescriptionText = "Starts the spelling checker"
.Caption = "mmutiphaseBOM"
.OnAction = "mmutipahseBOM"
End With
End Sub

840205910 · 发表于 2016-3-23 15:24

蓝桥玄霜的收藏.rar (1.19 MB, 下载次数: 376)

840205910 · 发表于 2016-3-26 08:30

公历农历.rar (1.79 MB, 下载次数: 189)

		自动登录	找回密码
密码			免费注册