下面的代码可以使用vba来并发完成吗？

Question

这段代码用一个模板，产生2025年每天的日报表备用。

Sub saleReport()
    t1 = Timer()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim templatePath As String
    Dim oYear, oMonth, DaysInMonth As Integer
    templatePath = "d:\templateSale.xlsx"
    Set wb = Workbooks.Open(templatePath)
    Set ws = wb.Sheets(1)
    oYera = 2025
    For oMonth = 1 To 12
        DaysInMonth = Day(DateSerial(oYear, oMonth + 1, 1) - 1)
        For oDay = 1 To DaysInMonth
            fn = "2025年" + CStr(oMonth) + "月" + CStr(oDay) + "日的销售报表"
            newFilePath = "d:\" + fn + ".xlsx"
            ws.Name = fn
            wb.SaveAs Filename:=newFilePath, FileFormat:=xlOpenXMLWorkbook
        Next oDay
    Next oMonth
    wb.Close SaveChanges:=False
    Set wb = Nothing
    Set ws = Nothing
    t2 = Timer()
    Debug.Print t2 - t1
End Sub

程序运行了23秒。有无办法使用vba来并行调用我的4核cpu?将速度降低在几秒内？

Answer 1

Python或者c++这种多线程的语言试试，
用 Python multiprocessing 模块并发：

import openpyxl
from multiprocessing import Pool
import os
import datetime

def create_daily_report(date_tuple):
    year, month, day = date_tuple
    template_path = "d:\\templateSale.xlsx"
    new_file_name = f"{year}年{month}月{day}日的销售报表.xlsx"
    new_file_path = os.path.join("d:\\", new_file_name)

    workbook = openpyxl.load_workbook(template_path)
    worksheet = workbook.active
    worksheet.title = new_file_name
    # ... 根据日期修改工作表 ...

    workbook.save(new_file_path)
    workbook.close()
    print(f"已生成：{new_file_path}")

if __name__ == "__main__":
    year = 2025
    dates = []
    for month in range(1, 13):
        days_in_month = (datetime.date(year, month + 1, 1) - datetime.timedelta(days=1)).day if month < 12 else 31
        for day in range(1, days_in_month + 1):
            dates.append((year, month, day))

    # 4个进程的进程池
    with Pool(processes=4) as pool:
        pool.map(create_daily_report, dates)

    print("所有报表生成完毕！")

Answer 2

你这样的场景，可以使用多线程方式解决：

' 引入必要的Windows API函数声明
Private Declare PtrSafe Function CreateThread Lib "kernel32" ( _
    ByVal lpThreadAttributes As LongPtr, _
    ByVal dwStackSize As Long, _
    ByVal lpStartAddress As LongPtr, _
    lpParameter As Any, _
    ByVal dwCreationFlags As Long, _
    lpThreadId As LongPtr _
) As LongPtr

Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As LongPtr _
) As Long

' 定义一个自定义数据类型，用于传递参数给线程函数
Type ThreadParams
    TemplatePath As String
    YearValue As Integer
    MonthValue As Integer
    DayValue As Integer
    NewFilePath As String
End Type

Answer 3

Sub saleReport()

Dim t1 As Double, t2 As Double
t1 = Timer()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim wb As Workbook
Dim ws As Worksheet
Dim templatePath As String
Dim oYear As Integer, oMonth As Integer, DaysInMonth As Integer
Dim oDay As Integer
Dim fn As String, newFilePath As String

templatePath = "d:\templateSale.xlsx"
Set wb = Workbooks.Open(templatePath)
Set ws = wb.Sheets(1)
oYear = 2025

For oMonth = 1 To 12
    DaysInMonth = Day(DateSerial(oYear, oMonth + 1, 1) - 1)
    For oDay = 1 To DaysInMonth
        fn = "2025年" & CStr(oMonth) & "月" & CStr(oDay) & "日的销售报表"
        newFilePath = "d:\" & fn & ".xlsx"
        ws.Name = fn
        wb.SaveAs Filename:=newFilePath, FileFormat:=xlOpenXMLWorkbook
    Next oDay
Next oMonth

wb.Close SaveChanges:=False
Set wb = Nothing
Set ws = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

t2 = Timer()
Debug.Print "运行时间：" & t2 - t1 & "秒"

End Sub