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

840205910 · 发表于 2016-4-16 16:30

用户djdl密码fff888限用10次.rar (639.71 KB, 下载次数: 245)

840205910 · 发表于 2016-4-16 16:34

协纪辩方择日软件，绿色，无需安装，无需注册，自含数据库，试用版

有需要正式版的请联系我，收费的哦！

840205910 · 发表于 2016-5-4 16:20

Private Sub CommandButton1_Click() '批量提取Word的数据到表格
Dim WordApp As Object, DOC, mTable, Fn$, Str$
On Error Resume Next
CreateObject("wscript.shell").Run "cmd.exe /c dir """ & ThisWorkbook.Path & "\*.docx"" /s/b>""" & ThisWorkbook.Path & "\list.txt""", False, True    '取得指定目录下的word文档清单
Set WordApp = CreateObject("word.application")  '创建word程序项目（用于操作word文档）
WordApp.Visible = True  '设定word程序项目可见
Open ThisWorkbook.Path & "\list.txt" For Input As #1 '打开清单文件并读取内容
  ReDim arr(1 To 10, 1 To 5)
  WordApp.ScreenUpdating = False
  While Not EOF(1) '循环读取清单文件各行内容
Input #1, Str '输入一行文本到变量str中
If Trim(Str) <> "" Then '如果文本有效则
   Set DOC = WordApp.documents.Open(Trim(Str)) '利用word程序项目打开对应的word文档
      With DOC
      n = n + 1
      arr(n, 1) = Trim(Mid(.Sentences(2), 6, 10)) '第2句的6---15字符                         '.Range(Start:=38, End:=46))总字符数
      arr(n, 2) = Replace(Replace(.Sentences(15), Chr(7), ""), Chr(13), "")
      arr(n, 3) = Replace(Replace(.Sentences(16), Chr(7), ""), Chr(13), "")
      arr(n, 4) = Replace(Replace(.Sentences(17), Chr(7), ""), Chr(13), "")
      arr(n, 5) = Replace(Replace(.Sentences(18), Chr(7), ""), Chr(13), "")
      .Close False '关闭word文档
      End With
End If
Wend
Close #1 '关闭清单文件
If Dir(ThisWorkbook.Path & "\list.txt") <> "" Then Kill ThisWorkbook.Path & "\list.txt"    '删除清单文件
WordApp.Quit 'word程序项目关闭
Set DOC = Nothing '清空对应项目变量
Set WordApp = Nothing
WordApp.ScreenUpdating = True
[a2].Resize(10, 5) = arr

End Sub

840205910 · 发表于 2016-5-4 20:30

Private Sub CommandButton2_Click() '邮件合并
Set Wd = CreateObject("word.application")
Wd.Visible = True
myph = ThisWorkbook.Path
b = InputBox("请输入数据开始行", "提示")
c = InputBox("请输入数据结束行", "提示")
  arr = Sheet1.UsedRange
For i = b To c
FileCopy myph & "\询证函.docx", myph & "\" & Sheets("数据").Range("A" & i) & ".docx"
                           nm2 = myph & "\" & Sheets("数据").Range("A" & i) & ".docx"
With Wd
   Set DOC = .Documents.Open(nm2)
      Str1 = "单位名称：       "
      Str2 = "单位名称：" & arr(i, 1)
      If .Selection.Find.Execute(Str1) Then  '查找到指定字符串
         .Selection.Text = Str2 '替换字符串
      End If
      With DOC
         .Sentences(15) = arr(i, 2)
         .Sentences(16) = arr(i, 3)
         .Sentences(17) = arr(i, 4)
         .Sentences(18) = arr(i, 5)
         .Close True
      End With
   End With
Next
Wd.Quit
Set DOC = Nothing
Set Wd = Nothing
End Sub

840205910 · 发表于 2016-5-4 20:32

提取Word数据到Excel.rar (62.35 KB, 下载次数: 120)

840205910 · 发表于 2016-5-4 20:33

生成Word.rar (34.65 KB, 下载次数: 114)

840205910 · 发表于 2016-5-8 14:45

Private Sub CommandButton2_Click() '填附件并发送
Set Wd = CreateObject("word.application")
Dim NameSpace$, FSO As Object, Email As Object, TW As Workbook, FN$
  NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
' Set FSO = CreateObject("Scripting.FileSystemObject")
  Wd.Visible = True
myph = ThisWorkbook.Path
b = InputBox("请输入数据开始行", "提示")
c = InputBox("请输入数据结束行", "提示")
  arr = Sheet1.UsedRange
For i = b To c
FileCopy myph & "\询证函.docx", myph & "\" & Sheets("数据").Range("A" & i) & ".docx"
                           nm2 = myph & "\" & Sheets("数据").Range("A" & i) & ".docx"
With Wd
   Set DOC = .Documents.Open(nm2)
      Str1 = "单位名称：       "
      Str2 = "单位名称：" & arr(i, 1)
      If .Selection.Find.Execute(Str1) Then  '查找到指定字符串
         .Selection.Text = Str2 '替换字符串
      End If
         With DOC
         .Sentences(15) = arr(i, 2)
         .Sentences(16) = arr(i, 3)
         .Sentences(17) = arr(i, 4)
         .Sentences(18) = arr(i, 5)
         .Close True
         End With
   End With
   Set Email = CreateObject("CDO.Message")
   Email.AddAttachment nm2
   With Email
.FROM = "840205910@qq.com" '发件人邮箱，无需打开
.TO = "1670665265@qq.com"  '收件人邮箱，无需打开
.Subject = "邮件主题"
.TextBody = "邮件正文"
With .Configuration.Fields
   .Item(NameSpace & "smtpusessl") = 1
   .Item(NameSpace & "sendusing") = 2
   .Item(NameSpace & "smtpserver") = "smtp.qq.com"
   .Item(NameSpace & "smtpserverport") = "465"
   .Item(NameSpace & "smtpauthenticate") = 1
   .Item(NameSpace & "sendusername") = "840205910@qq.com"
   .Item(NameSpace & "sendpassword") = "独立邮箱密码"
   .Update
End With
.Send
End With

  MsgBox "OK"
  Next
Wd.Quit
Set DOC = Nothing
Set Wd = Nothing
End Sub

840205910 · 发表于 2016-5-9 16:52

生成WORD附件发送到QQ.zip (36.29 KB, 下载次数: 72)

840205910 · 发表于 2016-5-18 20:52

Private Sub CommandButton1_Click()
Set cnn = CreateObject("adodb.connection") '连接
Set rst = CreateObject("ADODB.Recordset") '记录集
cnn.Open "Provider=sqloledb;Server=192.168.1.200;Database=ForeignTrade;Uid=sa;Pwd=hshs123456;"
Sql = "SELECT ClientInnerOrderMain.or_nu,ClientInnerOrderMain.Client_na,ClientInnerOrderListBasic.co_nu,ClientInnerOrderListBasic.pr_na,ClientInnerOrderListBasic.amount * ClientInnerOrderListBasic.ou_lo,ClientInnerOrderListBasic.ha_in_qu ,ClientInnerOrderListBasic.amount * ClientInnerOrderListBasic.ou_lo*ClientInnerOrderListBasic.ha_in_qu ,Manufacturer.ma_na,ClientInnerOrderListBasic.en_da,ClientInnerOrderMain.days FROM ClientInnerOrderMain,ClientInnerOrderListBasic,Manufacturer WHERE ClientInnerOrderMain.number = ClientInnerOrderListBasic.Number and ClientInnerOrderListBasic.ma_nu = Manufacturer.ma_nu and ClientInnerOrderListBasic.en_da > '2016-02-01'" 'ORDER BY ClientInnerOrderMain.or_nu "
Sheet1.Range("a2:j10000") = ""
Sheet1.Range("a2").CopyFromRecordset cnn.Execute(Sql)
Sql = "select ClientOrderMain.or_nu, ClientOrderMain.Client_na,ClientOrderListBasic.co_nu ,ClientOrderListBasic.pr_na,ClientOrderListBasic.ou_lo*ClientOrderListBasic.amount,ClientOrderListBasic.ha_in_qu,ClientOrderListBasic.ou_lo*ClientOrderListBasic.amount*ClientOrderListBasic.ha_in_qu,Manufacturer.ma_na,ClientOrderMain.HappenDate,ClientOrderMain.Abstract from ClientOrderMain,ClientOrderListBasic,Manufacturer WHERE ClientOrderMain.number=ClientOrderListBasic.Number and ClientOrderListBasic.ma_nu=Manufacturer.ma_nu and ClientOrderMain.en_da > '2016-02-01'" 'ORDER BY ClientOrderMain.or_nu"
n = Sheet1.Range("a65500").End(3).Row + 1
Sheet1.Range("a" & n).CopyFromRecordset cnn.Execute(Sql)
cnn.Close
Set cnn = Nothing
Sheet1.Range("A:j").Sort Key1:=Columns("A"), Order1:=xlAscending, Header:=xlYes
End Sub

840205910 · 发表于 2016-5-18 20:53

Private Sub CommandButton1_Click()
Set cnn = CreateObject("adodb.connection") '连接
Set rst = CreateObject("ADODB.Recordset") '记录集
cnn.Open "Provider=sqloledb;Server=192.168.1.200;Database=hsproduction;Uid=sa;Pwd=hshs123456;"
Sql = " SELECT StockOrderManageList.PlanNumber, StockOrderManageList.BarCode,StockOrderManageList.Name,StockOrderManageList.Amount,StockOrderManageList.Price,StockOrderManageList.Amount*StockOrderManageList.Price, DatumManufacturer.Name FROM DatumManufacturer, StockOrderManageList WHERE DatumManufacturer.Number=StockOrderManageList.MaNumber and StockOrderManageList.PlanNumber> '20160201001' "
Sheet2.Range("a2:h20000") = ""
Sheet2.Range("a2").CopyFromRecordset cnn.Execute(Sql)
cnn.Close
Set cnn = Nothing
Set cnn = CreateObject("adodb.connection") '连接
Set rst = CreateObject("ADODB.Recordset") '记录集
cnn.Open "Provider=sqloledb;Server=192.168.1.200;Database=ForeignTrade;Uid=sa;Pwd=hshs123456;"
Sql = "SELECT ManufacturerInnerOrderMain.or_nu,ManufacturerInnerOrderListBasic.co_nu,ManufacturerInnerOrderListBasic.pr_na,ManufacturerInnerOrderListBasic.ou_lo*ManufacturerInnerOrderListBasic.amount,ManufacturerInnerOrderListBasic.or_pr,ManufacturerInnerOrderListBasic.ou_lo*ManufacturerInnerOrderListBasic.amount*ManufacturerInnerOrderListBasic.or_pr,Manufacturer.ma_na,ManufacturerInnerOrderMain.HappenDate FROM ManufacturerInnerOrderMain,ManufacturerInnerOrderListBasic,Manufacturer WHERE ManufacturerInnerOrderMain.number=ManufacturerInnerOrderListBasic.Number and ManufacturerInnerOrderListBasic.ma_nu=Manufacturer.ma_nu and ManufacturerInnerOrderMain.HappenDate > '2016-02-01'"
n = Sheet2.Range("a65500").End(3).Row + 1
Sheet2.Range("a" & n).CopyFromRecordset cnn.Execute(Sql)
Sql = "select ManufacturerEnWarehouseMain.or_nu,ManufacturerEnWarehouseListBasic.co_nu,ManufacturerEnWarehouseListBasic.pr_na,ManufacturerEnWarehouseListBasic.ou_lo*ManufacturerEnWarehouseListBasic.amount,ManufacturerEnWarehouseListBasic.or_pr,ManufacturerEnWarehouseListBasic.ou_lo*ManufacturerEnWarehouseListBasic.amount*ManufacturerEnWarehouseListBasic.or_pr,Manufacturer.ma_na,ManufacturerEnWarehouseMain.HappenDate from ManufacturerEnWarehouseMain ,ManufacturerEnWarehouseListBasic,Manufacturer WHERE ManufacturerEnWarehouseMain.number=ManufacturerEnWarehouseListBasic.Number and ManufacturerEnWarehouseListBasic.ma_nu=Manufacturer.ma_nu and ManufacturerEnWarehouseMain.HappenDate > '2016-02-01'"
n = Sheet2.Range("a65500").End(3).Row + 1
Sheet2.Range("a" & n).CopyFromRecordset cnn.Execute(Sql)
cnn.Close
Set cnn = Nothing
Sheet2.Range("A:h").Sort Key1:=Columns("A"), Order1:=xlAscending, Header:=xlYes
End Sub

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