我们以日报表为例，讲述生成的过程

一、先手动制作好模板文件，包括合并单元格、设置单元格格式等，模板文件的全路径为：D:Excels产量日报表模板.xlsx

二、生成日报表文件

因为可能要查询归档数据，所以生成时间我们把这个时间点定在每天的00:15:00。这个可以组态时间触发器来完成。

1、组态全局动作：

Option Explicit

Function action

   Dim Yesterday,sYesterday  

   Yesterday = DateAdd("d", -1, Date)

   sYesterday = CStr(Year(Yesterday)) _

              & "-" & Right("00" & CStr(Month(Yesterday)),2) _

              & "-" & Right("00" & CStr(Day(Yesterday)),2)

   Call DayReport(sYesterday)

End Function

触发器为每天的00:15:00触发，以便生成昨天的日报表

2、生成日报表

日报表的完整名称为：D:\Excels\2024-10\产量日报表(2024-10-06).xlsx

Public Sub DayReport(strDate)

   '如：strDate = 2024-10-06

   Dim xlApp

   Dim xlBook

   Dim xlSheet

   Dim sFileName,sSourceFile

   sSourceFile = "D:\Excels\产量日报表模板.xlsx"

   sFileName = "D:\Excels\" & Left(strDate,7) & "\产量日报表(" & strDate & ")" & ".xlsx"

   CheckFileExists sSourceFile, sFileName

   CloseApplication sFileName

   Set xlApp = CreateObject("Excel.Application")

   Set xlBook = xlApp.Workbooks.Open(sFileName)

   Set xlSheet = xlBook.Worksheets(1)

   xlApp.DisplayAlerts = False

   '以下是往Excel单元格中写入内容(代码略)

   xlBook.Save

   xlApp.Quit

   Set xlSheet = Nothing

   Set xlBook = Nothing

   Set xlApp = Nothing

End Sub

3、模块中用到的两个函数：

一个是拷贝文件(项目函数)：

Public Sub CheckFileExists(SourceFile, FullFile)

   Dim fs

   Dim sFolder

   Dim iPos

   iPos = InStrRev(FullFile, "")

   If iPos <= 3 Then

      Exit Sub

   End If

   Set fs = CreateObject("Scripting.FileSystemObject")

   '创建月份文件夹，如：D:\Excels\2024-10

   sFolder = Left(FullFile, iPos - 1)

   If Not fs.FolderExists(sFolder) Then

      fs.CreateFolder sFolder

   End If

‘如果目标文件不存在，则拷贝文件

   If Not fs.FileExists(FullFile) Then

      fs.CopyFile SourceFile,FullFile,True

   End If

   Set fs = Nothing

End Sub

第二个是检查Excel文件(日报表文件)是否已打开，如果已打开，则关闭它(项目函数)：

Public Sub CloseApplication(FullFile)

   Dim objApp

   Dim objWorkbook

   On Error Resume Next

   Set objApp = GetObject(, "Excel.Application")

   If Err.Number <> 0 Then

      Exit Sub

   End If

   objApp.DisplayAlerts = False

   For Each objWorkbook In objApp.Workbooks

      If UCase(objWorkbook.FullName) = UCase(FullFile) Then

         objWorkbook.Close False

      End If

   Next

   Set objApp = Nothing

End Sub