Sub ExportSheet()
'
' Macro1 Macro
' 宏由 红色金刚石 录制,时间: 2015-3-14
'
On Error Resume Next
Dim e_path As String
e_path = ThisWorkbook.path & "\" & "Export_" & CStr(Year(Date)) ' & "_" & Month(Date)
thePathIsExistsAndMkit e_path
Dim ffilter, initfname, str_path As String
Dim fname As String
fname = ""
ffilter = "EXCEL97/2000/2003文件 (*.xls), *.xls|文本文件 (*.txt), *.txt|所有文件 (*.*), *.*"
str_path = Left(ThisWorkbook.name, InStr(ThisWorkbook.name, ".") - 1)
str_path = str_path & "_" & InitView.GetCurDwmc
str_path = str_path & "_" & CStr(Date)
initfname = e_path & "\" & str_path
fname = Application.GetSaveAsFilename( _
fileFilter:=ffilter, _
InitialFileName:=initfname)
If Not Trim(fname) = "" And Not Trim(fname) = "False" Then
Sheets("明细表").Select
Sheets("明细表").Copy
For Each s In Sheets
s.UsedRange = s.UsedRange.value
Next
ChDir "."
ActiveWorkbook.SaveAs Filename:=fname, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWorkbook.Close 1
Else
MsgBox "未能导出文件或用户取消操作!", vbInformation, "提示"
End If
End Sub
Public Sub thePathIsExistsAndMkit(pathName As String)
'如果子目录不存在,则建立之
Dim mypathtofind As Object
Set mypathtofind = CreateObject("Scripting.FileSystemObject")
If Not mypathtofind.folderExists(pathName) Then
mypathtofind.createfolder (pathName)
End If
End Sub
Sub ExportSheet2()
'
' Macro1 Macro
' 宏由 红色金刚石 录制,时间: 2015-3-14
'
On Error Resume Next
Dim e_path As String
e_path = ThisWorkbook.path & "\" & "Export_" & CStr(Year(Date)) ' & "_" & Month(Date)
thePathIsExistsAndMkit e_path
Dim ffilter, initfname, str_path As String
Dim fname As String
fname = ""
ffilter = "EXCEL97/2000/2003文件 (*.xls), *.xls|文本文件 (*.txt), *.txt|所有文件 (*.*), *.*"
str_path = Left(ThisWorkbook.name, InStr(ThisWorkbook.name, ".") - 1)
str_path = str_path & "_" & InitView.GetCurDwmc
str_path = str_path & "_" & CStr(Date)
initfname = e_path & "\" & str_path
fname = Application.GetSaveAsFilename( _
fileFilter:=ffilter, _
InitialFileName:=initfname)
If Not Trim(fname) = "" And Not Trim(fname) = "False" Then
Dim wb As Workbook
Set wb = Workbooks.Add(ThisWorkbook.path & "\template\templatedetaile.xls")
Dim s_t_title, s_t_fz, s_t_bbdw, s_t_bbsj As String
s_t_title = PublicProperty.当前工作年月 & PublicProperty.Sydwmc & "护士奖金发放明细表"
Dim dwlist() As String
dwlist = SheetsSet.xtdwlist
Dim k
For k = 0 To UBound(dwlist, 1)
If PublicProperty.当前计算单位 = dwlist(1, k + 1) Then
s_t_fz = IIf(k > 0, "之" & Application.Text(k, "[DBnum1]"), "")
End If
Next
s_t_title = s_t_title & s_t_fz
s_t_bbdw = PublicProperty.Sydwmc
s_t_bbsj = Format(Date, "yyyy年mm月dd日")
With wb
.ActiveSheet.Cells(1, 1).value = s_t_title
.ActiveSheet.Cells(2, 4).value = s_t_bbdw
.ActiveSheet.Cells(2, 23).value = s_t_bbsj
Dim i_f, i_e
i_f = ThisWorkbook.RngFind("序号", Range("a1:y100")).row
i_e = ThisWorkbook.RngFind("合计", Range("a1:y100")).row
Dim 表格行数
表格行数 = i_e - i_f - 3
Dim a_jjsj() As String
a_jjsj = filteData(ImportFfData)
Dim i, j
If 表格行数 < UBound(a_jjsj, 2) Then
Dim zjh
zjh = UBound(a_jjsj, 2) - 表格行数
For i = 0 To zjh + PublicProperty.显示空行数
Rows("" & i_e + i - 1 & ":" & i_e + i - 1).Select
Selection.Insert Shift:=xlDown
Next
End If
Dim s_dw As String
s_dw = PublicProperty.当前计算单位
For i = 0 To UBound(a_jjsj, 2)
For j = 1 To UBound(a_jjsj, 1) - 1
.ActiveSheet.Cells(i + i_f + 3, j + 1).value = a_jjsj(j, i)
Next
.ActiveSheet.Cells(i + i_f + 3, 1).value = i + 1
Next
End With
ActiveWorkbook.SaveAs Filename:=fname, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWorkbook.Close 1
Else
MsgBox "未能导出文件或用户取消操作!", vbInformation, "提示"
End If
End Sub
第一种是用拷贝粘贴,第二种用模板。
个人认为第二种更灵活。