Public Sub uftxt()
'***定义程序所使用的变量
Dim YYbank As Range '*** excel中待选区域
Dim FileName As String '*** 最后生成用友文本文件名
Dim Msg As Integer
'------------------------------------------
Worksheets("导入工具").Activate
Range("A1").Select
If Range("A2").Value = "" Then Exit Sub ' 防止没有数据导致出错
'Selection.CurrentRegion.Select ' 本来这一句就可以了，但是因为工作表保护了，所以需要下面两句才能实现
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
'move by fengrui
'Msg = MsgBox("运行此程序前请将需要生成用友文本文件的有效数据区域选中" & Chr(13) & Chr(13) & _
"(包括表头及数据行,但不要整行选取)" & Chr(13) & Chr(13) & _
"是否已按上述要求选中有效数据区域?" & Chr(13) & Chr(13) & _
"如果已正确选取数据区域请点" & Chr(34) & "是" & Chr(34) & "程序继续运行," & Chr(13) & Chr(13) & _
"否则点" & Chr(34) & "否" & Chr(34) & "暂时退出,以便重新选择区域...." _
, vbYesNo + vbInformation, "请选择")
'If Msg = vbNo Then Exit Sub
'-------除此处以及使用时间增加一个月外，没有对其他任何部分做修改。------------------------------
Set YYbank = Selection '***将所选excel数据区赋值给 YYbank
'***判断所选excel数据区域是否符合用友标准凭证准备表格式
With YYbank
If .Cells(1) <> "日期" Or .Cells(2) <> "凭证类别" Or .Cells(3) <> "凭证号" Or .Cells(4) <> "附单据数" Or .Cells(5) <> "摘要" Or _
.Cells(6) <> "科目编码" Or .Cells(7) <> "借方金额" Or .Cells(8) <> "贷方金额" Or .Cells(9) <> "数量" Or .Cells(10) <> "外币" Or _
.Cells(11) <> "汇率" Or .Cells(12) <> "制单人" Or .Cells(13) <> "结算方式" Or .Cells(14) <> "票号" Or .Cells(15) <> "票号发生日期" Or .Cells(16) <> "部门编码" Or .Cells(17) <> "个人编码" Or _
.Cells(18) <> "客户编码" Or .Cells(19) <> "供应商编码" Or .Cells(20) <> "业务员" Or .Cells(21) <> "项目编码" Or .Cells(22) <> "出库性质" Then
MsgBox "程序检测到您所选取的数据区域与用友导入文本文件要求格式不一致,请检查....", vbOKOnly + vbCritical, "数据区域选择错误"
Exit Sub
End If
End With
Set YYbank = YYbank.Offset(1).Resize(YYbank.Rows.Count - 1) '***去除YYbank的第一行即列名
Filenumber = FreeFile() '***取得一个可用文件号
'***文本文件名,格式为日期加时间形如"2005-10-27 09：16_.txt",默认保存在excel文件所在目录
FileName = ActiveWorkbook.Path & "\" & Date & Format(Time, " hh：mm;@") & "_.txt"
If Dir(FileName) <> "" Then Kill FileName '***如果有相同文件名则先将其删除
'***开始写用友文本文件
Open FileName For Output As #Filenumber
Print #Filenumber, "填制凭证,V800" ' PZstring
Call XSPZ(YYbank, Filenumber) '调用写用友文本文件的函数-见后面的 Function XSPZ()
Close #Filenumber
MsgBox "用友文本文件已生成：" & Chr(13) & Chr(13) & FileName, vbInformation
End Sub
'***写用友文本文件的一个子程序(函数)
Private Function XSPZ(ByVal YYbank As Range, ByVal Filenumber As Integer) As Integer
Dim PZstr As String, i As Integer, II As Integer, YH As String * 1
YH = Chr(34) '***引号
With YYbank
i = .Rows.Count
PZstr = ""
For II = 1 To i
PZstr = Format(.Cells(II, 1), "yyyy/mm/dd") & "," & YH & .Cells(II, 2) & YH & "," & YH & .Cells(II, 3) & YH & "," & .Cells(II, 4) & "," & YH & .Cells(II, 5) & YH & "," & YH & .Cells(II, 6) & YH & "," & .Cells(II, 7) & "," & .Cells(II, 8) & "," & .Cells(II, 9) & "," & .Cells(II, 10) & " ," & .Cells(II, 11) & "," & YH & .Cells(II, 12) & YH & "," & YH & .Cells(II, 13) & YH & "," & YH & .Cells(II, 14) & YH & "," & YH & .Cells(II, 15) & YH & "," & YH & .Cells(II, 16) & YH & "," & YH & .Cells(II, 17) & YH & "," & YH & .Cells(II, 18) & YH & "," & YH & .Cells(II, 19) & YH & "," & YH & .Cells(II, 20) & YH & "," & YH & .Cells(II, 21) & YH & "," & .Cells(II, 22)
Print #Filenumber, PZstr '***写入文本
Next II
End With
End Function
