EXCEL 2 word 的一些案例。excel通过一些策略将内容写入word中。
vbnet
'==================================================================
'说明2025-8-12 PHASE_EXCEL表格内容导入到Word中。
'用来定位工作表
'用来定位PHASE类型
'用来定位置换变量
'用来生成word1级标题
'用来生成word2级标题
'用来生成word3级标题
'
'用来生成word表格第1行
'用来生成word表格第2行
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'excel操作word常量表
Const wdPreferredWidthPoints As Long = 3
Const wdLineStyleSingle As Long = 1
Const wdLineWidth050pt As Long = 2
Const wdColorBlack As Long = 0
Const wdBorderTop As Long = -1
Const wdBorderLeft As Long = -2
Const wdBorderBottom As Long = -3
Const wdBorderRight As Long = -4
Const wdBorderHorizontal As Long = -5
Const wdBorderVertical As Long = -6
' ========== 模块级变量：使用不易冲突的名称 ==========
Private Dict_Sheets As Object
Private Dict_Aliases As Object
' ========== 声明在模块最顶部（所有 Sub 之上）==========
Dim wdApp As Object ' Word 应用程序对象
Dim wdDoc As Object ' 当前 Word 文档对象
Dim SectionCounter As Object ' 存储章节编号状态：Dict("L1"=1, "L2"=1, ...)
'判断是否需要清空标题计数，判断是否是新创建的doc文档。
Dim flg_resetcounter As Boolean, IsNewDoc As Boolean
'用户设置标题，需要从用户设置的开始计数2025-8-29
Dim flg_UserCounter As Boolean
' ========== 初始化函数 ==========
Sub InitSheetsCollection()
Dim wb As Workbook
Dim Ws As Worksheet
' ===== 清理旧对象 =====
If Not Dict_Sheets Is Nothing Then Set Dict_Sheets = Nothing
If Not Dict_Aliases Is Nothing Then Set Dict_Aliases = Nothing
' ===== 创建新字典 =====
Set Dict_Sheets = CreateObject("Scripting.Dictionary")
Set Dict_Aliases = CreateObject("Scripting.Dictionary")
' 设置不区分大小写
Dict_Sheets.CompareMode = vbTextCompare
Dict_Aliases.CompareMode = vbTextCompare
' 获取目标工作簿
Set wb = GetWorkbookByName(sheet_comb_sor.text)
If wb Is Nothing Then
MsgBox "? 找不到工作簿: " & sheet_comb_sor.text, vbCritical
Exit Sub
End If
' 遍历所有工作表，存入字典
For Each Ws In wb.Worksheets
Set Dict_Sheets(Ws.name) = Ws ' ? 安全赋值
Next Ws
Debug.Print "? 已加载 " & Dict_Sheets.count & " 个工作表到内存。"
If Dict_Sheets.count > 0 Then
Debug.Print " 可用表名: " & Join(Dict_Sheets.Keys, ", ")
End If
End Sub
' ========== 自定义：厘米转磅值 ==========
Public Function CentimetersToPoints(cm As Double) As Double
' 1 厘米 = 28.3464567 磅（标准转换）
CentimetersToPoints = cm * 28.3464567
End Function
' ========== 主调用函数：通过表名或别名获取工作表对象 ==========
Function SheetsCollection(ByVal sheetKey As String) As Worksheet
Dim actualName As String
Dim matchedCount As Long
Dim matchName As String
Dim k As Variant
' 1. 先查别名
If Dict_Aliases.Exists(sheetKey) Then
actualName = Dict_Aliases(sheetKey)
If Dict_Sheets.Exists(actualName) Then
Set SheetsCollection = Dict_Sheets(actualName)
Exit Function
End If
End If
' 2. 精确匹配表名
If Dict_Sheets.Exists(sheetKey) Then
Set SheetsCollection = Dict_Sheets(sheetKey)
Exit Function
End If
' 3. 模糊匹配：包含关键词
matchedCount = 0
For Each k In Dict_Sheets.Keys
If InStr(1, k, sheetKey, vbTextCompare) > 0 Then
matchedCount = matchedCount + 1
matchName = k
End If
Next k
' 4. 返回结果
Select Case matchedCount
Case 1
Set SheetsCollection = Dict_Sheets(matchName)
Case 0
Set SheetsCollection = Nothing
Debug.Print "? 未找到匹配: '" & sheetKey & "'"
Case Else
Set SheetsCollection = Nothing
Debug.Print "?? 模糊匹配歧义: '" & sheetKey & "' 匹配到 " & matchedCount & " 个表"
End Select
End Function
' ========== 管理别名映射 ==========
Sub AddSheetAlias(Alias As String, ActualSheetName As String)
' 添加别名映射
If Not SheetsCollection_Internal.Exists(ActualSheetName) Then
Debug.Print "?? 无法添加别名: 工作表 '" & ActualSheetName & "' 不存在。"
Exit Sub
End If
NameMapping(Alias) = ActualSheetName
Debug.Print "?? 别名映射: '" & Alias & "' → '" & ActualSheetName & "'"
End Sub
' ========== 查询所有可用表名和别名 ==========
Sub ListAllSheetsAndAliases()
Debug.Print "?? 当前可用工作表:"
Dim k As Variant
For Each k In SheetsCollection_Internal.Keys
Debug.Print " ?? " & k
Next k
If NameMapping.count > 0 Then
Debug.Print "?? 别名映射:"
For Each k In NameMapping.Keys
Debug.Print " ?? '" & k & "' → '" & NameMapping(k) & "'"
Next k
End If
End Sub
Function RemoveCRLF(ByVal txt As String) As String
' 去掉回车换行符，保留其他字符
Dim result As String
result = Replace(txt, vbCrLf, "") ' 去掉 CRLF
result = Replace(result, vbCr, "") ' 去掉 CR
result = Replace(result, vbLf, "") ' 去掉 LF
RemoveCRLF = result
End Function
Function ReplaceCurlyBraces(strText As String, replacement As String) As String
' 参数说明：
' strText: 原始包含花括号的文本，例如 "你好{name}，欢迎来到{place}"
' replacement: 要替换成的内容，例如 "XXX" 或 "张三"
Dim regex As Object
' 创建正则表达式对象
Set regex = CreateObject("VBScript.RegExp")
' 设置正则表达式属性
With regex
.Global = True ' 替换所有匹配项
.IgnoreCase = True ' 不区分大小写
.Pattern = "\{[^}]*\}" ' 匹配 {任意非}字符}，包括花括号本身
End With
' 执行替换并返回结果
ReplaceCurlyBraces = regex.Replace(strText, replacement)
' 清理对象
Set regex = Nothing
End Function
Function GetWorkbookByName(name As String) As Workbook
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.name = name Then
Set GetWorkbookByName = wb
Exit Function
End If
Next wb
Set GetWorkbookByName = Nothing
End Function
Function GetFirstRowAsArray(Ws As Worksheet) As Variant
Dim LastCol As Long
Dim i As Long
Dim RowArray() As Variant
' 错误处理，防止空对象
If Ws Is Nothing Then
MsgBox "工作表对象无效！", vbCritical
GetFirstRowAsArray = Array() ' 返回空数组
Exit Function
End If
' 获取第一行最右侧有数据的列号
On Error Resume Next
LastCol = Ws.Cells(1, Ws.Columns.count).End(xlToLeft).Column
If Err.Number <> 0 Then
LastCol = 1 ' 如果出错（如整行为空或表为空），设为第1列
Err.Clear
End If
On Error GoTo 0
' 确保至少有一个列
If LastCol < 1 Then LastCol = 1
' 定义动态数组，从1到LastCol
ReDim RowArray(1 To LastCol)
' 遍历第一行所有列，获取每个单元格的值（包括空值）
For i = 1 To LastCol
RowArray(i) = Ws.Cells(1, i).value
Next i
' 返回结果数组
GetFirstRowAsArray = RowArray
End Function
'文字替换见
Function ReplacePlaceholders(mappingStr As String, textStr As String) As String
Dim result As String
result = textStr
' === 清理输入：统一替换全角符号为半角 ===
mappingStr = Replace(Trim(mappingStr), "。", ".")
mappingStr = Replace(mappingStr, "：", ":")
mappingStr = Replace(mappingStr, " ", "") ' 可选：去除空格干扰
textStr = Replace(Trim(textStr), "。", ".") ' 统一文本中的分号
' 注意：{ } 必须保持半角，不处理
' === 解析映射表 ===
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
If mappingStr = "" Then GoTo PerformReplacement
Dim parts As Variant
parts = Split(mappingStr, ".")
Dim i As Integer
Dim part As String, key As String, value As String
Dim pair As Variant
For i = 0 To UBound(parts)
part = Trim(parts(i))
If part = "" Then GoTo NextPart
' 支持 : 和 ： 已统一为 :
pair = Split(part, ":", 2)
If UBound(pair) >= 1 Then
key = Trim(pair(0))
value = Trim(pair(1))
If key <> "" And Not dict.Exists(key) Then
dict.Add key, value
End If
End If
NextPart:
Next i
' === 执行替换：逐个查找 {xxx} ===
PerformReplacement:
Dim startPos As Integer, endPos As Integer
Dim varName As String, placeholder As String
Dim temp As String
temp = result
startPos = InStr(temp, "{")
Do While startPos > 0
endPos = InStr(startPos, temp, "}")
If endPos = 0 Then Exit Do ' 无闭合 }
varName = Mid(temp, startPos + 1, endPos - startPos - 1)
If dict.Exists(varName) Then
placeholder = "{" & varName & "}"
temp = Left(temp, startPos - 1) & dict(varName) & Mid(temp, endPos + 1)
' 避免死循环：从替换后的位置继续
startPos = InStr(startPos + Len(dict(varName)), temp, "{")
Else
startPos = InStr(endPos, temp, "{")
End If
Loop
result = temp
' === 可选：清理末尾多余标点（根据需求开启）===
' 如果您希望末尾统一为句号或无标点，可启用：
' Do While Right(result, 1) = ";" Or Right(result, 1) = "；" Or Right(result, 1) = "."
' result = Left(result, Len(result) - 1)
' Loop
' result = result & "。" ' 添加中文句号（可选）
ReplacePlaceholders = result
End Function
'====================================================================================================
'创建word文档
Sub CreateWordDocument(ByVal Doc_name As String)
Dim excelFolder As String
Dim fileName As String
Dim fileTime As String
' 生成时间戳：精确到分钟（如 202508120330）
fileTime = Format(Now, "yyyymmddhhnn")
' 文件名
fileName = "Phase_" & Doc_name & "_" & fileTime & ".docx"
' Excel 所在文件夹
excelFolder = ThisWorkbook.path
If excelFolder = "" Then
MsgBox "请先保存 Excel 文件！", vbExclamation
Exit Sub
End If
fileName = excelFolder & "\" & fileName
' 启动 Word（如果未运行）
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
' 设置可见
wdApp.Visible = True
' 创建新文档
Set wdDoc = wdApp.Documents.Add
' 保存为指定路径
wdDoc.SaveAs2 fileName, 16 '16代表wdFormatXMLDocument（即.docx格式）
' 提示
Debug.Print "Word 文档已创建：" & vbCrLf & fileName, vbInformation
End Sub
Sub CopyWordAndSave(ByVal Doc_name As String)
Dim excelFolder As String
Dim fileName As String
Dim fileTime As String
' 生成时间戳：精确到分钟（如 202508120330）
fileTime = Format(Now, "yyyymmddhhnn")
' 文件名
fileName = "Phase_" & Doc_name & "_" & fileTime & ".docx"
' 设置源文件路径和目标保存路径
sourcePath = ThisWorkbook.path & "\模板.docx" '替换为实际路径
fileName = ThisWorkbook.path & "\" & fileName ' 替换为实际保存路径
' 启动 Word（如果未运行）
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
'复制文件（通过打开并另存为）
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(sourcePath)
' 保存文档
wdDoc.SaveAs2 fileName, 16 '16代表wdFormatXMLDocument（即.docx格式）
' 提示
Debug.Print "Word 文档已创建：" & vbCrLf & fileName, vbInformation
End Sub
Sub AddSectionToWord(dataDict As Object, ByVal Doc_name As String)
'增加标题序号
' 检查 Word 是否还活着，否则重建
'If Not IsWordAlive Then
'If CreateNewWordDocument(Doc_name) = False Then
' MsgBox "无法启动 Word，请检查是否安装。", vbCritical
' Exit Sub
'End If
'End If
If Not IsWordAlive Then
If CopyNewWordAndSave(Doc_name) = False Then
MsgBox "无法启动 Word，请检查是否安装。", vbCritical
Exit Sub
End If
End If
' 初始化计数器
If SectionCounter Is Nothing Then Set SectionCounter = CreateObject("Scripting.Dictionary")
L1VIS.text = SectionCounter("L1")
L2VIS.text = SectionCounter("L2")
L3VIS.text = SectionCounter("L3")
Dim title1 As String, title2 As String, title3 As String
Dim tableData As Variant
Dim currentNumber As String
Dim rng As Object
' 获取数据
title1 = GetDictValue(dataDict, "Title1", "")
title2 = GetDictValue(dataDict, "Title2", "")
title3 = GetDictValue(dataDict, "Title3", "")
tableData = GetDictValue(dataDict, "TableData", "")
' 获取文档范围
Set rng = wdDoc.Content
rng.Collapse 0 ' 折叠到末尾
' ========== 处理标题：编号逻辑 ==========
'如果一级标题不是空，说明是新的phase功能了，要重置L2;L3.2025-8-13
'这里重置为了后续update加一做准备2025-8-13
'这部分必须前置，也就是说，初始化为0，后边会加1
If flg_resetcounter = True Then
ResetCounter "L1"
If title1 <> "" Then ResetCounter "L2,L3"
If title2 <> "" Then ResetCounter "L3"
End If
If flg_UserCounter = False Then
'如果用户没有自定义标题，就按下边执行
If title1 <> "" Then
'isnewdoc=true，新打开的文档，需要升级L2 L3标题，标题1一直会正常升级。2025-8-13
UpdateCounter "L1", True
UpdateCounter "L2", False
UpdateCounter "L3", False
currentNumber = SectionCounter("L1")
AddHeading rng, currentNumber & ". " & title1, 1
End If
If title2 <> "" Then
UpdateCounter "L2"
UpdateCounter "L3", False
currentNumber = SectionCounter("L1") & "." & SectionCounter("L2")
AddHeading rng, currentNumber & ". " & title2, 2
End If
If title3 <> "" Then
UpdateCounter "L3"
currentNumber = SectionCounter("L1") & "." & SectionCounter("L2") & "." & SectionCounter("L3")
AddHeading rng, currentNumber & ". " & title3, 3
End If
Else
'不处理，因为公共变量已经在外部设置好。但是执行一次要将变量置假
flg_UserCounter = False
'isnewdoc=true，新打开的文档，需要升级L2 L3标题，标题1一直会正常升级。2025-8-13
UpdateCounter "L1", False
UpdateCounter "L2", False
UpdateCounter "L3", False
currentNumber = SectionCounter("L1")
AddHeading rng, currentNumber & ". " & title1, 1
currentNumber = SectionCounter("L1") & "." & SectionCounter("L2")
AddHeading rng, currentNumber & ". " & title2, 2
currentNumber = SectionCounter("L1") & "." & SectionCounter("L2") & "." & SectionCounter("L3")
AddHeading rng, currentNumber & ". " & title3, 3
End If
Dim iLL%, SZ_iLL As Variant
SZ_iLL = Split("L1;L2;L3", ";")
For iLL = 0 To 2
Debug.Print SZ_iLL(iLL) & "=" & SectionCounter(SZ_iLL(iLL))
Next iLL
' ========== 插入表格：使用安全判断 ==========
If IsArray(tableData) Then
If GetArrayDimensions(tableData) = 2 Then
'检查和创建表格样式
Call CreateOrUpdateTableStyle
InsertTable rng, tableData
End If
End If
' 保存文档
On Error Resume Next
wdDoc.Save
On Error GoTo 0
End Sub
Function FormatToThreeDigit(ByVal a As Variant) As String
' 将输入的三个值格式化为两位数，并用下划线连接
FormatToThreeDigit = Format(a, "000")
End Function
' 辅助函数 1：获取字典值（带默认值）
Function GetDictValue(dict As Object, key As String, defaultValue As Variant) As Variant
If dict.Exists(key) Then
GetDictValue = dict(key)
Else
GetDictValue = defaultValue
End If
End Function
'辅助函数 2：更新编号计数器
Sub UpdateCounter(ByVal level As String, Optional increment As Boolean = True)
If Not SectionCounter.Exists(level) Then SectionCounter.Add level, 0
'如果需要重置计数就加1，否则就不加1
If increment Then SectionCounter(level) = SectionCounter(level) + 1
L1VIS.text = SectionCounter("L1")
L2VIS.text = SectionCounter("L2")
L3VIS.text = SectionCounter("L3")
End Sub
' 辅助函数 3：重置低层级编号重置成0
Sub ResetCounter(levels As String)
Dim level As Variant
For Each level In Split(levels, ",")
level = Trim(level)
If SectionCounter.Exists(level) Then SectionCounter(level) = 0
L1VIS.text = SectionCounter("L1")
L2VIS.text = SectionCounter("L2")
L3VIS.text = SectionCounter("L3")
Next
End Sub
'设置标题样式，方便日后生成目录2025-8-29
Sub SetHeadingStyles()
' 修改"标题 1"样式
With ActiveDocument.Styles("标题 1").Font
.name = "仿宋"
.Size = 14
.Bold = True
End With
With ActiveDocument.Styles("标题 1").ParagraphFormat
.SpaceAfter = 6
.Alignment = 0 ' 左对齐
End With
' 修改"标题 2"样式
With ActiveDocument.Styles("标题 2").Font
.name = "仿宋"
.Size = 12
.Bold = True
End With
With ActiveDocument.Styles("标题 2").ParagraphFormat
.SpaceAfter = 6
.Alignment = 0
End With
' 修改"标题 3"样式
With ActiveDocument.Styles("标题 3").Font
.name = "仿宋"
.Size = 10
.Bold = False
End With
With ActiveDocument.Styles("标题 3").ParagraphFormat
.SpaceAfter = 6
.Alignment = 0
End With
End Sub
'' 超安全版 AddHeading（推荐使用）
'Sub AddHeading(rng As Object, text As String, level As Integer)
' Dim para As Object
'
' ' 折叠到末尾并插入标题
' rng.Collapse 0
' ' 设置格式
' ' 获取最后一个段落（即刚插入的标题）
' Set para = wdDoc.Paragraphs(wdDoc.Paragraphs.count)
' With para.Range.Font
' Select Case level
' Case 1
' .Size = 14
' .Bold = True
' .name = "仿宋"
' Case 2
' .Size = 12
' .Bold = True
' .name = "仿宋"
' Case 3
' .Size = 10
' .Bold = False
' .name = "仿宋"
' Case Else
' .Size = 10
' End Select
' End With
'
' rng.InsertAfter text & vbCrLf
' rng.Collapse 0 ' 确保光标在末尾
'
' para.SpaceAfter = 6 ' 段后间距
' para.Alignment = 0 ' 0 = wdAlignParagraphLeft（左对齐）
'
'
'
'End Sub
'可生成目录版本的标题，2025-8-29
Sub AddHeading(rng As Object, text As String, level As Integer)
Dim para As Object
Dim styleName As String
' 根据 level 选择样式
Select Case level
Case 1: styleName = "标题 1"
Case 2: styleName = "标题 2"
Case 3: styleName = "标题 3"
Case Else: styleName = "正文"
End Select
' 插入文本
rng.Collapse 0
rng.InsertAfter text
rng.Collapse 0
' 获取刚插入的段落
' 应用标题样式（此时会自动使用你定义的格式）
If level = 3 Then
Set para = wdDoc.Paragraphs(wdDoc.Paragraphs.count)
para.Range.Style = styleName
rng.InsertAfter vbCrLf
rng.Collapse 0
Set para = wdDoc.Paragraphs(wdDoc.Paragraphs.count)
'检查是否有表格样式，没有就创建
Call CreateOrUpdateTableStyle
styleName = "表格"
para.Range.Style = styleName
rng.Collapse 0
Else
Set para = wdDoc.Paragraphs(wdDoc.Paragraphs.count)
para.Range.Style = styleName
rng.InsertAfter vbCrLf
rng.Collapse 0
End If
rng.Collapse 0
End Sub
' 辅助函数 5：插入表格（安全版本）
' ============================================================================
' 安全插入表格到 Word 文档
' 支持：非 0 起始数组、空值处理、维度检查、错误防护
' ============================================================================
'创建表格样式2025-8-29
Sub CreateOrUpdateTableStyle()
Dim styleName As String: styleName = "表格"
Dim sty As Object
On Error Resume Next
Set sty = wdDoc.Styles(styleName)
On Error GoTo 0
If sty Is Nothing Then
' 样式不存在，创建
Set sty = wdDoc.Styles.Add(name:=styleName, Type:=wdStyleTypeParagraph)
sty.BaseStyle = "正文"
Debug.Print "? 创建样式: " & styleName
Else
' 样式存在，可选：删除重建 或 修改
' 方法1：删除重建（确保干净）
wdDoc.Styles(styleName).Delete ' 删除旧样式
Set sty = wdDoc.Styles.Add(name:=styleName, Type:=wdStyleTypeParagraph)
sty.BaseStyle = "正文"
Debug.Print "?? 重建样式: " & styleName
End If
' 统一设置格式
With sty
.Font.NameFarEast = "仿宋"
.Font.Size = 12
.ParagraphFormat.SpaceAfter = 6
.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
Debug.Print "?? 样式格式已应用: " & styleName
End Sub
' 插入表格（主函数）
Sub InsertTable(rng As Object, data As Variant)
' 参数检查：必须是二维数组
If Not IsArray(data) Then Exit Sub
If IsEmpty(data) Then Exit Sub
Dim dims As Integer
dims = GetArrayDimensions(data)
If dims <> 2 Then Exit Sub ' 必须是二维
Dim lb1 As Long, ub1 As Long
Dim lb2 As Long, ub2 As Long
Dim rowCount As Long, colCount As Long
' 获取边界
On Error GoTo ErrorHandler
lb1 = LBound(data, 1): ub1 = UBound(data, 1)
lb2 = LBound(data, 2): ub2 = UBound(data, 2)
On Error GoTo 0
rowCount = ub1 - lb1 + 1
colCount = ub2 - lb2 + 1
If rowCount < 1 Or colCount < 1 Then Exit Sub
' 折叠到末尾，插入段落
rng.Collapse 0
'rng.InsertParagraphAfter
'rng.Collapse 0
' 添加表格
Dim tbl As Object
Set tbl = wdDoc.Tables.Add(rng, rowCount, colCount)
' 填入数据
Dim i As Long, j As Long
Dim r As Long, c As Long ' Word 表格行/列从 1 开始
For i = lb1 To ub1
For j = lb2 To ub2
r = i - lb1 + 1
c = j - lb2 + 1
Sleep 100
tbl.cell(r, c).Range.text = Nz(data(i, j))
Next j
Next i
With tbl
' 计算可用宽度 (单位: 磅)
Dim usableWidth As Single
usableWidth = .Parent.PageSetup.pageWidth _
- .Parent.PageSetup.leftMargin _
- .Parent.PageSetup.rightMargin
' 设置列宽
.Columns(1).PreferredWidthType = wdPreferredWidthPoints
.Columns(1).PreferredWidth = CentimetersToPoints(2.5)
.Columns(2).PreferredWidthType = wdPreferredWidthPoints
.Columns(2).PreferredWidth = usableWidth - CentimetersToPoints(2.5) - CentimetersToPoints(0.2)
' 3. 首行为标题行
.Rows(1).HeadingFormat = False
' 5. 所有边框设为实线（兼容写法）
For i = 1 To 6
With .Borders(i)
.LineStyle = 1 ' 实线
.Color = 0 ' 黑色
.Visible = True ' 关键：确保可见！
End With
Next i
' === 新增：统一设置表格格式，解决行间距不一致问题 ===
' 1. 设置所有单元格段落格式
With .Range.Paragraphs
.LineSpacingRule = wdLineSpaceSingle ' 单倍行距
.SpaceBefore = 0 ' 段前间距0
.SpaceAfter = 0 ' 段后间距0
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
End With
' 2. 设置所有行为"固定行高"，避免自动拉伸
Dim row As Object
For Each row In .Rows
row.HeightRule = wdRowHeightExactly ' 精确指定行高
row.Height = CentimetersToPoints(0.8) ' 设置固定高度，如 0.8 厘米
Next row
' ' 3. 可选：设置字体和对齐（更美观）
' .Range.Font.name = "宋体"
' .Range.Font.Size = 10.5
' .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter ' 居中对齐
' ' 4. 防止自动调整表格
' .AllowAutoFit = False ' 关闭自动适应
' .AutoFitBehavior (wdAutoFitFixed) ' 固定列宽
' 5.表格在页面居中
.Rows.HeightRule = wdRowHeightAuto '自动行高
End With
On Error GoTo 0
' 光标回到末尾
rng.Collapse 0
'rng.InsertParagraphAfter
rng.Collapse 0
Exit Sub
ErrorHandler:
MsgBox "InsertTable 错误: " & Err.Description, vbCritical
End Sub
' 获取数组维度数（修正版，安全可靠）
Function GetArrayDimensions(arr As Variant) As Integer
Dim i As Integer
Dim ub As Long
If Not IsArray(arr) Then
GetArrayDimensions = 0
Exit Function
End If
On Error GoTo Finalize
i = 1
Do While True
ub = UBound(arr, i)
i = i + 1
Loop
Finalize:
GetArrayDimensions = i - 1
End Function
' 防止 Null/Empty 写入 Word（Word 不支持 Null）
Function Nz(v As Variant, Optional defaultValue As String = "") As String
If IsNull(v) Or IsEmpty(v) Then
Nz = defaultValue
Else
On Error Resume Next
Nz = CStr(v)
If Err.Number <> 0 Then Nz = defaultValue
On Error GoTo 0
End If
End Function
' 检查 Word 是否仍然可用
Function IsWordAlive() As Boolean
On Error GoTo NotAlive
' 只要 wdApp 和 wdDoc 不为 Nothing，且能访问属性，就认为活着
If wdApp Is Nothing Or wdDoc Is Nothing Then
GoTo NotAlive
End If
' 尝试访问文档名称（触发 COM 通信）
Dim dummy As String
dummy = wdDoc.name ' 如果文档已关闭，会出错
IsWordAlive = True
Exit Function
NotAlive:
IsWordAlive = False
' 清理无效对象
Set wdDoc = Nothing
Set wdApp = Nothing
End Function
' 创建新的 Word 应用和文档
Function CreateNewWordDocument(ByVal Doc_name As String) As Boolean
On Error GoTo ErrHandler
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
' 保存到 Excel 同目录，命名带时间
Dim fileName As String
fileName = ThisWorkbook.path & "\Phase_" & Doc_name & "_" & Format(Now, "yyyymmddhhnnss") & ".docx"
wdDoc.SaveAs2 fileName, 16 '16代表wdFormatXMLDocument（即.docx格式）
CreateNewWordDocument = True
Exit Function
ErrHandler:
MsgBox "启动 Word 失败：" & Err.Description, vbCritical
CreateNewWordDocument = False
Set wdDoc = Nothing
Set wdApp = Nothing
End Function
'复制新的word应用和文档
Function CopyNewWordAndSave(ByVal Doc_name As String) As Boolean
On Error GoTo ErrHandler
Dim excelFolder As String
Dim fileName As String
Dim fileTime As String
' 生成时间戳：精确到分钟（如 202508120330）
fileTime = Format(Now, "yyyymmddhhnn")
' 文件名
fileName = "Phase_" & Doc_name & "_" & fileTime & ".docx"
' 设置源文件路径和目标保存路径
sourcePath = ThisWorkbook.path & "\模板.docx" '替换为实际路径
fileName = ThisWorkbook.path & "\" & fileName ' 替换为实际保存路径
Set wdApp = GetObject(, "Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(sourcePath)
wdDoc.SaveAs2 fileName, 16 '16代表wdFormatXMLDocument（即.docx格式）
CopyNewWordAndSave = True
Exit Function
ErrHandler:
MsgBox "启动 Word 失败：" & Err.Description, vbCritical
CreateNewWordDocument = False
Set wdDoc = Nothing
Set wdApp = Nothing
End Function
Private Sub get_workbooks()
Dim wb As Workbook
Dim path As String
sheet_comb_sor.Clear
' 遍历所有已打开的工作簿
On Error Resume Next
For Each wb In Application.Workbooks
' 获取每个工作簿的路径
path = wb.path
' 如果工作簿未保存，则路径可能为空
If path <> "" Then
' 将路径添加到组合框中
sheet_comb_sor.AddItem wb.name
End If
Next wb
sheet_comb_sor.ListIndex = 0
End Sub
Private Sub but_createDoc_Click()
'a = ReplaceCurlyBraces("aaaa{a不不不}a", "123")
Dim Ws As Worksheet, Ws_Sor As Worksheet
Dim Str_phase_name$, Str_phase_type$
Dim Col_phase_type%
Dim SZ_Col_fun As Variant, SZ_col_name As Variant
Dim i%
Dim tem_TiHuanZiDian$
Dim Main_loop%, str_Row As Long, end_Row As Long
Dim Doc_name$
'初始化部分数据:
str_Row = T_str_Row.text
end_Row = T_end_Row.text
'默认是第一个文档，必须要重置标题计数。2025-8-13
'flg_resetcounter = True '取消这个强制项，手动更改起始值时要确保有效。2025-8-29
'锁定PHASE类型相关数据行
'找到Str_phase_type所在列
SZ_Col_fun = Split(T_col_fun, vbCrLf)
SZ_col_name = Split(T_Col_name, vbCrLf)
Dim the_Runing$
the_Runing = "RUNNING"
'
'用来定位工作表-Col_mark_sheet_no
'用来定位PHASE类型-Col_mark_phasetype_no
'用来定位置换变量-Col_mark_Value
'用来生成word1级标题-Col_biaoti1
'用来生成word2级标题-Col_biaoti2
'用来生成word3级标题-Col_biaoti3
'
'用来生成word表格第1行-Col_table_row1
'用来生成word表格第2行-Col_talbe_row2
'1. 构造字典,需要变动，改为循环外部，定义一次即可。
Dim dataDict2doc As Object
Set dataDict2doc = CreateObject("Scripting.Dictionary")
Dim Col_mark_sheet_no%
Dim Col_mark_phasetype_no%
Dim Col_mark_Value%
Dim Col_biaoti1%, Col_biaoti2%, Col_biaoti3%
Dim Col_table_Row1%, Col_table_Row2%, Col_table_Row3%
Dim s_Table_Rows$, SZ_Table_Rows As Variant '用来生成表格的前几行数据
'方法/属性 说明
'.Add Key, Item 添加一个键值对
'.Exists(Key) 检查某个键是否存在（返回 True/False）
'.Remove(Key) 删除指定键的条目
'.RemoveAll 清空整个字典
'.Count 返回字典中键值对的数量
'.Keys 返回所有键的数组
'.Items 返回所有值的数组
'.Key(Key) 修改某个键（较少用）
Set zd_Table_Rows = CreateObject("Scripting.Dictionary")
s_Table_Rows = ""
For i = LBound(SZ_Col_fun) To UBound(SZ_Col_fun)
Select Case SZ_Col_fun(i)
Case Is = "用来定位工作表"
Col_mark_sheet_no = i
Case Is = "用来定位PHASE类型"
Col_mark_phasetype_no = i
Case Is = "用来定位置换变量"
Col_mark_Value = i
Case Is = "用来生成word1级标题"
Col_biaoti1 = i
Case Is = "用来生成word2级标题"
Col_biaoti2 = i
Case Is = "用来生成word3级标题"
Col_biaoti3 = i
End Select
Next i
Dim Col_PhaseNo% '在phase表中，phase类型所在的列号
Dim S_phase_type_row$, S_phase_type_Col$, S_phase_type_Col_ref$ '存储与phase类型相关的行号,列号;分割。
Dim SZ_phase_type_row As Variant, SZ_phase_type_CoL As Variant, SZ_phase_type_Col_ref As Variant
Dim i_used_Row%, i_used_Col%
Dim tem_S As String
Dim ii%
'参考的源工作表
Set Ws_Sor = SheetsCollection(ws_comb_Sor)
If str_Row > end_Row Then
MsgBox "起始行和结束行输入错误，起始行必须比结束行小或者相等。"
GoTo PEND
End If
'获取表格第一行、第二行、第三行所在的列号，未后续增加数据作为引用。2025-8-16
s_Table_Rows = ""
For i = 1 To Ws_Sor.UsedRange.Columns.count
Select Case Ws_Sor.Cells(1, i).value
'2025-8-16增加表格前三行
Case Is = "PHASE类型_表1"
Col_table_Row1 = i
s_Table_Rows = s_Table_Rows & i & ";"
Case Is = "PHASE位号_表2"
Col_table_Row2 = i
s_Table_Rows = s_Table_Rows & i & ";"
Case Is = "流程图号_表3"
Col_table_Row3 = i
s_Table_Rows = s_Table_Rows & i & ";"
End Select
Next i
s_Table_Rows = Left(s_Table_Rows, Len(s_Table_Rows) - 1)
SZ_Table_Rows = Split(s_Table_Rows, ";")
'把unit列作为word的名字。
'注释掉2025-8-13，无需要在这里创建word
'Doc_name = Ws_Sor.Cells(str_Row, 2)
'创建word文档
'注释掉2025-8-13，无需要在这里创建word
'CreateWordDocument Doc_name
'当unit更改后，创建新的word。
'存储当前是第几个文档，和存储当前处理的第几次数据
Dim DOC_Count As Integer, Row_cishu As Integer
'默认是第一个文档
DOC_Count = 1
Row_cishu = 0
'主循环
For Main_loop = str_Row To end_Row
Row_cishu = Row_cishu + 1
tem_TiHuanZiDian = Ws_Sor.Cells(Main_loop, Col_mark_Value + 1)
'锁定工作表
'Set Ws = SheetsCollection(Str_phase_name)
'定位工作表名
tem_S = SZ_col_name(Col_mark_sheet_no)
Debug.Print tem_S
Set Ws = SheetsCollection(Ws_Sor.Cells(Main_loop, Col_mark_sheet_no + 1)) '温度、压力、进料、等等
'WS是空的就跳转下一条
If Ws Is Nothing Then
MsgBox "未找到表：" & Ws_Sor.Cells(Main_loop, Col_mark_sheet_no + 1)
GoTo NEXT_MAIN_LOOP
End If
'找到phase类型对应的列号
For i = 1 To Ws.UsedRange.Columns.count
If Ws.Cells(1, i).value = SZ_col_name(Col_mark_phasetype_no) Then
Col_PhaseNo = i
Exit For
End If
Next i
'寻找某个类型相关的所有行号，为处理数据做准备。
S_phase_type_row = ""
i_used_Row = Ws.UsedRange.Rows.count
For i = 1 To i_used_Row
'出现总循环函数
If Ws.Cells(i, Col_PhaseNo).value = Ws_Sor.Cells(Main_loop, Col_mark_phasetype_no + 1).value Then
S_phase_type_row = S_phase_type_row & i & ";"
End If
Next i
'去掉最后一个分号
If Right(S_phase_type_row, 1) = ";" Then
S_phase_type_row = Left(S_phase_type_row, Len(S_phase_type_row) - 1)
End If
'里程碑：获得某个phase类型相关的行的数组。
SZ_phase_type_row = Split(S_phase_type_row, ";")
'获得所要提取数据的列号数组，数据净化，去掉末尾的不小心输入的回车
Dim tempText As String
tempText = T_PHASE_Col.text
' 清理：去除首尾空白、换行、制表符等
S_phase_type_Col_ref = VBA.Strings.Trim(tempText)
' 再分割（此时不会有多余空元素）
SZ_phase_type_Col_ref = Split(S_phase_type_Col_ref, vbCrLf)
Dim Col_celue_no% '策略所在列
S_phase_type_Col = ""
For i = 1 To Ws.UsedRange.Columns.count
If Ws.Cells(1, i).value = "策略" Then
Col_celue_no = i
Else
'标题行，例如：设定参数（配方）、参数（操作）。。。所在列
For ii = LBound(SZ_phase_type_Col_ref) To UBound(SZ_phase_type_Col_ref)
If Ws.Cells(1, i).value = SZ_phase_type_Col_ref(ii) And SZ_phase_type_Col_ref(ii) <> "" Then
S_phase_type_Col = S_phase_type_Col & i & ";"
Exit For
End If
Next ii
End If
Next i
'去掉最后一个分号
If Right(S_phase_type_Col, 1) = ";" Then
S_phase_type_Col = Left(S_phase_type_Col, Len(S_phase_type_Col) - 1)
End If
'里程碑：获取某个phase类型相关的【列号数组】
SZ_phase_type_CoL = Split(S_phase_type_Col, ";")
Dim tem_TiHuanQian$, tem_TiHuanJieGuoDanYuan$
Dim SZ_TiHuanJieGuoDanYuan As Variant
Dim SZ_phase_type_CoL_L%, SZ_phase_type_CoL_U%, SZ_phase_type_Row_L%, SZ_phase_type_Row_U%
Dim Cell_col_no%, Cell_row_no%
SZ_phase_type_CoL_L = LBound(SZ_phase_type_CoL)
SZ_phase_type_CoL_U = UBound(SZ_phase_type_CoL)
SZ_phase_type_Row_L = LBound(SZ_phase_type_row)
SZ_phase_type_Row_U = UBound(SZ_phase_type_row)
If SZ_phase_type_CoL_U <> UBound(SZ_phase_type_Col_ref) Then
MsgBox "word的表格内容列信息与某个phase的第一行标题不符，禁止继续执行！"
GoTo PEND
End If
'
'
' For i = 1 To Ws.usedRange.Columns.Count
' Debug.Print Ws_Sor.Cells(1, i).value
' Select Case Ws_Sor.Cells(1, i).value
'
' Case Is = tbl_Phase_style
' i_Tbl_phase_style = i
' Case Is = tbl_Phase_No
' i_Tbl_phase_No = i
' End Select
' Next i
ReDim SZ_TiHuanJieGuoDanYuan(SZ_phase_type_CoL_L To SZ_phase_type_CoL_U + UBound(SZ_Table_Rows) + 1, 0 To 1)
'前两行分别写入【PHASE类型】和【PHASE位号】
For i = LBound(SZ_Table_Rows) To UBound(SZ_Table_Rows)
For j = 0 To 1
Select Case j
Case Is = 0
tem_S = RemoveCRLF(Ws_Sor.Cells(1, CInt(SZ_Table_Rows(i))).value)
SZ_TiHuanJieGuoDanYuan(i, j) = Left(tem_S, Len(tem_S) - 3)
Case Is = 1
tem_S = RemoveCRLF(Ws_Sor.Cells(Main_loop, CInt(SZ_Table_Rows(i))).value)
SZ_TiHuanJieGuoDanYuan(i, j) = tem_S
End Select
Next j
Next i
' SZ_TiHuanJieGuoDanYuan(0, 0) = RemoveCRLF(Left(tbl_Phase_style, Len(tbl_Phase_style) - 3))
' SZ_TiHuanJieGuoDanYuan(0, 1) = Ws_Sor.Cells(Main_loop, Col_table_Row1).value
' SZ_TiHuanJieGuoDanYuan(1, 0) = RemoveCRLF(Left(tbl_Phase_No, Len(tbl_Phase_No) - 3))
' SZ_TiHuanJieGuoDanYuan(1, 1) = Ws_Sor.Cells(Main_loop, Col_table_Row2).value
' SZ_TiHuanJieGuoDanYuan(2, 0) = RemoveCRLF(Left(tbl_Phase_No, Len(tbl_Phase_No) - 3))
' SZ_TiHuanJieGuoDanYuan(2, 1) = Ws_Sor.Cells(Main_loop, Col_table_Row3).value
'根据第一行，作为标题，逐列合并数据
For ii = SZ_phase_type_CoL_L To SZ_phase_type_CoL_U
tem_TiHuanJieGuoDanYuan = ""
'获得需要合并内容的列号，存入Cell_col_no
Cell_col_no = CInt(SZ_phase_type_CoL(ii))
'在这一列ii中，合并每行的数据。
For i = SZ_phase_type_Row_L To SZ_phase_type_Row_U
Debug.Print "行标签：" & Ws.Cells(CInt(SZ_phase_type_row(i)), Cell_col_no)
'将需要获取数据的行，存入Cell_row_no
Cell_row_no = CInt(SZ_phase_type_row(i))
Debug.Print "列内容：" & Ws.Cells(Cell_row_no, Cell_col_no)
'替换前的原始数据
tem_TiHuanQian = Ws.Cells(Cell_row_no, Cell_col_no).value
'根据字典内容，和替换规则函数，对数据{}包裹的对象进行替换。
'只有运行增加【策略】,其他不增加策略
If Ws.Cells(1, Cell_col_no) = the_Runing Then
If tem_TiHuanJieGuoDanYuan <> "" Then
If Ws.Cells(Cell_row_no, Col_celue_no) <> "" Then
tem_TiHuanJieGuoDanYuan = tem_TiHuanJieGuoDanYuan & vbCrLf & vbCrLf & _
"****" & Ws.Cells(Cell_row_no, Col_celue_no).value & "****" & vbCrLf & _
ReplacePlaceholders(tem_TiHuanZiDian, tem_TiHuanQian)
Else
tem_TiHuanJieGuoDanYuan = tem_TiHuanJieGuoDanYuan & _
ReplacePlaceholders(tem_TiHuanZiDian, tem_TiHuanQian)
End If
Else
If Ws.Cells(Cell_row_no, Col_celue_no) <> "" Then
tem_TiHuanJieGuoDanYuan = tem_TiHuanJieGuoDanYuan & _
"****" & Ws.Cells(Cell_row_no, Col_celue_no).value & "****" & vbCrLf & _
ReplacePlaceholders(tem_TiHuanZiDian, tem_TiHuanQian)
Else
tem_TiHuanJieGuoDanYuan = tem_TiHuanJieGuoDanYuan & _
ReplacePlaceholders(tem_TiHuanZiDian, tem_TiHuanQian)
End If
End If
Else
tem_TiHuanJieGuoDanYuan = tem_TiHuanJieGuoDanYuan & _
ReplacePlaceholders(tem_TiHuanZiDian, tem_TiHuanQian)
End If
Debug.Print tem_TiHuanJieGuoDanYuan
Next i
'增加前缀
'tem_TiHuanJieGuoDanYuan = Ws.Cells(Cell_row_no, Col_celue_no).value & "：" & vbCrLf & tem_TiHuanJieGuoDanYuan
'将数据存入2维数组。
SZ_TiHuanJieGuoDanYuan(ii + UBound(SZ_Table_Rows) + 1, 0) = SZ_phase_type_Col_ref(ii)
SZ_TiHuanJieGuoDanYuan(ii + UBound(SZ_Table_Rows) + 1, 1) = tem_TiHuanJieGuoDanYuan
Next ii
'里程碑: 创建word文档
' 3. 设置标题（示例，您可以根据实际逻辑修改）
'找到标题所在列的列号
Dim Sz_biaoti(3) As Variant
For j = 1 To Ws_Sor.UsedRange.Columns.count
If Ws_Sor.Cells(1, j).value = SZ_col_name(Col_biaoti1) Then
Sz_biaoti(0) = j
ElseIf Ws_Sor.Cells(1, j).value = SZ_col_name(Col_biaoti2) Then
Sz_biaoti(1) = j
ElseIf Ws_Sor.Cells(1, j).value = SZ_col_name(Col_biaoti3) Then
Sz_biaoti(2) = j
End If
Next j
'清空标题字典
dataDict2doc.RemoveAll
'第一行数据不需要判断,标题赋值好。2025-8-13
If Row_cishu > 1 Then
'其余次数提取数据要自动更新标题计数。
flg_resetcounter = False
End If
If Row_cishu = 1 Then
dataDict2doc.Add "Title1", Ws_Sor.Cells(Main_loop, Sz_biaoti(0))
dataDict2doc.Add "Title2", Ws_Sor.Cells(Main_loop, Sz_biaoti(1))
dataDict2doc.Add "Title3", Ws_Sor.Cells(Main_loop, Sz_biaoti(2)) ' 可留空
Debug.Print dataDict2doc("Title1")
Debug.Print dataDict2doc("Title2")
Debug.Print dataDict2doc("Title3")
'把unit列作为word的名字。2025-8-13
Doc_name = FormatToThreeDigit(SectionCounter("L1")) & "_" & Ws_Sor.Cells(Main_loop, 2)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'创建word文档,当unit更改后，创建新的word。2025-8-1
' CreateWordDocument Doc_name
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
CopyWordAndSave Doc_name
ElseIf Row_cishu > 1 And Ws_Sor.Cells(Main_loop, Sz_biaoti(0)) = Ws_Sor.Cells(Main_loop - 1, Sz_biaoti(0)) Then
'如果一级主题相等，在判断二级和三级，不能直接判断二级和三级2025-8-13
If Ws_Sor.Cells(Main_loop, Sz_biaoti(1)) <> Ws_Sor.Cells(Main_loop - 1, Sz_biaoti(1)) Then
dataDict2doc.Add "Title2", Ws_Sor.Cells(Main_loop, Sz_biaoti(1))
End If
'三级主题一直存在2025-8-13
If Row_cishu > 1 Then
dataDict2doc.Add "Title3", Ws_Sor.Cells(Main_loop, Sz_biaoti(2)) ' 可留空
End If
ElseIf Row_cishu > 1 And Ws_Sor.Cells(Main_loop, Sz_biaoti(0)) <> Ws_Sor.Cells(Main_loop - 1, Sz_biaoti(0)) Then
' 保存文档（可选：指定路径）
wdDoc.Save
' 关闭文档（不弹出对话框）
wdDoc.Close SaveChanges:=True ' 或 True，根据需要
'判断此时即将创建新文档.2025-8-13
IsNewDoc = True
If Flg_lianhao.value = False Then
'如果每个文档开头都是1.1.1要提前初始化等级标题，在生成文档2025-8-13
'文档标题要初始化成1.1.1，起始此时界面上指定的标题已经没有意义了2025-8-13
ref_levels
Else
'只把2级3级标题置1,一级标题要加1
ref_levels2and3
End If
'把unit列作为word的名字。2025-8-13
'这里先创建word后升级selectioncounter所以这里要提前+1，word序号匹配一级标题的序号。
Doc_name = FormatToThreeDigit(SectionCounter("L1") + 1) & "_" & Ws_Sor.Cells(Main_loop, 2)
'创建word文档,当unit更改后，创建新的word。2025-8-13
'创建word文档,当unit更改后，创建新的word。2025-8-1
' CreateWordDocument Doc_name
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
CopyWordAndSave Doc_name
'创建文档后也要更新二级和三级标题，不然新word第一项没有一级 二级和三级标题。
dataDict2doc.Add "Title1", Ws_Sor.Cells(Main_loop, Sz_biaoti(0))
If Ws_Sor.Cells(Main_loop, Sz_biaoti(1)) <> Ws_Sor.Cells(Main_loop - 1, Sz_biaoti(1)) Then
dataDict2doc.Add "Title2", Ws_Sor.Cells(Main_loop, Sz_biaoti(1))
End If
'三级主题一直存在2025-8-13
If Row_cishu > 1 Then
dataDict2doc.Add "Title3", Ws_Sor.Cells(Main_loop, Sz_biaoti(2)) ' 可留空
End If
End If
'字典增加表格数据
dataDict2doc.Add "TableData", SZ_TiHuanJieGuoDanYuan
'将字典写入word
AddSectionToWord dataDict2doc, Doc_name
'进度条
FMFCL.Caption = Format(100 * (Main_loop - str_Row + 1) / (end_Row - str_Row + 1), "#0.0") & "%"
FMFCL.Width = 500 * (Main_loop - str_Row + 1) / (end_Row - str_Row + 1)
If FMFCL.Width < 30 Then
FMFCL.Width = 30
End If
NEXT_MAIN_LOOP:
Next Main_loop
PEND:
' 保存文档（可选：指定路径）
wdDoc.Save
' 关闭文档（不弹出对话框）
wdDoc.Close SaveChanges:=True ' 或 True，根据需要
' 退出 Word 应用程序
wdApp.Quit
' 释放对象
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "程序结束！"
End Sub
Public Sub BUT_REF_LEVELS_Click()
ref_levels
'第一次创建word禁止升级标题，后续文档会自动升级标题
flg_resetcounter = False
flg_UserCounter = True
End Sub
Public Sub ref_levels()
'变动2025-8-13 初始化标题字典，并置0
'必须用public，否则不行，因为SectionCounter是公共函数
'重置标题序号
' 初始化计数器
If SectionCounter Is Nothing Then
Set SectionCounter = CreateObject("Scripting.Dictionary")
SectionCounter.Add "L1", CInt(T_LEVEL1.text)
SectionCounter.Add "L2", CInt(T_LEVEL2.text)
SectionCounter.Add "L3", CInt(T_LEVEL3.text)
SectionCounter("L1") = 1
SectionCounter("L2") = 1
SectionCounter("L3") = 1
'第一次特殊，激活flg_usercounter=true,也不要让计数升级标题
flg_UserCounter = True
Else
If CInt(T_LEVEL1.text) > 0 Then
SectionCounter("L1") = CInt(T_LEVEL1.text)
End If
If CInt(T_LEVEL2.text) > 0 Then
SectionCounter("L2") = CInt(T_LEVEL2.text)
End If
If CInt(T_LEVEL3.text) > 0 Then
SectionCounter("L3") = CInt(T_LEVEL3.text)
End If
End If
L1VIS.text = SectionCounter("L1")
L2VIS.text = SectionCounter("L2")
L3VIS.text = SectionCounter("L3")
Debug.Print "标题设置完成:" & SectionCounter("L1") & "." & SectionCounter("L2") & "." & SectionCounter("L3")
End Sub
Public Sub ref_levels2and3()
'新文档必须初始化2级3级标题。
If SectionCounter Is Nothing Then
Set SectionCounter = CreateObject("Scripting.Dictionary")
SectionCounter("L2") = 0
SectionCounter("L3") = 0
Else
SectionCounter("L2") = 0
SectionCounter("L3") = 0
End If
L2VIS.text = SectionCounter("L2")
L3VIS.text = SectionCounter("L3")
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub lb_but_ref_Col_NAME_Click()
get_ref_col_Name
End Sub
Private Sub get_ref_col_Name()
Dim S_Col_name As String
Dim ref_Wb As Workbook, ref_Ws As Worksheet
Dim SZ_Col As Variant
Dim i As Long
' 获取工作簿
Set ref_Wb = GetWorkbookByName(sheet_comb_sor.text)
If ref_Wb Is Nothing Then
MsgBox "指定的工作簿未找到或未打开！", vbExclamation
Exit Sub
End If
' 获取工作表
On Error Resume Next
Set ref_Ws = ref_Wb.Sheets(ws_comb_Sor.text)
On Error GoTo 0
If ref_Ws Is Nothing Then
MsgBox "工作簿中未找到名为 '" & ws_comb_Sor.text & "' 的工作表！", vbExclamation
Exit Sub
End If
' 获取第一行数据
SZ_Col = GetFirstRowAsArray(ref_Ws)
' 清空文本框
T_Col_name.text = ""
' 判断是否为数组且非空
If IsArray(SZ_Col) Then
' 正向遍历：从第一列到最后一列
For i = LBound(SZ_Col) To UBound(SZ_Col)
If Not IsEmpty(SZ_Col(i)) Then
T_Col_name.text = T_Col_name.text & SZ_Col(i)
Else
T_Col_name.text = T_Col_name.text & "<空列名>"
End If
' 添加换行符，但最后一项不加
If i < UBound(SZ_Col) Then
T_Col_name.text = T_Col_name.text & vbCrLf
End If
Next i
Else
T_Col_name.text = "<无法读取列名>"
End If
End Sub
Private Sub sheet_comb_sor_Change()
Dim wb As Workbook
Dim workbookName As String
If sheet_comb_sor.text <> "" Then
workbookName = sheet_comb_sor.text
Set wb = GetWorkbookByName(workbookName)
If Not wb Is Nothing Then
With ws_comb_Sor
.Clear
Dim sh As Worksheet
For Each sh In wb.Sheets
.AddItem sh.name
Next sh
.ListIndex = 0
End With
For i = 1 To ws_comb_Sor.ListCount
If ws_comb_Sor.List(i) = "771" Then
ws_comb_Sor.ListIndex = i
Exit For
End If
Next i
'获取所有表格内容到内存，准备调用。
InitSheetsCollection
Else
MsgBox "工作簿未找到或未打开", vbExclamation
End If
End If
End Sub
Private Sub ShuaXin_yuan_mubiao_Click()
'获取当前打开的表，更新到组合框
get_workbooks
End Sub
Private Sub T_col_fun_Change()
End Sub
Private Sub T_LEVEL1_Change()
End Sub
Private Sub UserForm_Initialize()
'初始化word标题等级2025-8-13
ref_levels
'不要升级一级标题，确保第一个是1
flg_resetcounter = True
flg_UserCounter = False
End Sub
Private Sub ws_comb_Sor_Change()
On Error Resume Next
If ws_comb_Sor.text <> "" Then
get_ref_col_Name
End If
End Sub