|
|
您提出了一个很好的问题。确实，如果宏在要处理的Excel文件中运行，会导致该文件被占用而无法参与汇总。以下是解决方案：
Sub 独立汇总工具()
Dim 文件夹路径 As String
Dim 文件列表 As Collection
Dim 文件名称 As String
Dim 基表文件名 As String
Dim 汇总工作簿 As Workbook
Dim 源工作簿 As Workbook
Dim 当前工作簿 As Workbook
Dim i As Integer, j As Integer
Dim 行号 As Long, 列号 As Integer
Dim 排除行 As String, 排除列 As String
Dim 排除行数组, 排除列数组
Dim 计数 As Integer
' 保存当前工作簿引用
Set 当前工作簿 = ThisWorkbook
' 1. 选择文件夹并获取xlsx文件列表
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "请选择包含报表的文件夹"
If .Show = -1 Then
文件夹路径 = .SelectedItems(1)
If Right(文件夹路径, 1) <> "\" Then
文件夹路径 = 文件夹路径 & "\"
End If
Else
MsgBox "未选择文件夹，操作已取消"
Exit Sub
End If
End With
' 使用更可靠的方法获取文件列表
Set 文件列表 = New Collection
文件名称 = Dir(文件夹路径 & "*.xlsx")
Do While 文件名称 <> ""
文件列表.Add 文件名称
文件名称 = Dir
Loop
If 文件列表.Count = 0 Then
MsgBox "在指定文件夹中未找到xlsx文件"
Exit Sub
End If
' 显示找到的文件列表
Dim 文件列表文本 As String
文件列表文本 = "找到以下xlsx文件：" & vbCrLf
For i = 1 To 文件列表.Count
文件列表文本 = 文件列表文本 & i & ". " & 文件列表(i) & vbCrLf
Next i
MsgBox 文件列表文本
' 2. 选择基表文件
基表文件名 = InputBox("请输入作为基表的文件名（如：123.xlsx）:", "选择基表", 文件列表(1))
If 基表文件名 = "" Then
MsgBox "未选择基表，操作已取消"
Exit Sub
End If
' 检查基表文件是否当前工作簿
If 当前工作簿.Name = 基表文件名 Then
MsgBox "不能选择当前工作簿作为基表，请选择其他文件"
Exit Sub
End If
' 复制基表创建汇总表
Workbooks.Open 文件夹路径 & 基表文件名
Set 源工作簿 = ActiveWorkbook
源工作簿.SaveCopyAs 文件夹路径 & "汇总表.xlsx"
源工作簿.Close
' 打开汇总表
Workbooks.Open 文件夹路径 & "汇总表.xlsx"
Set 汇总工作簿 = ActiveWorkbook
' 3. 获取排除的行列
排除行 = InputBox("请输入不参与统计的行号（用逗号分隔，如:1,2,3,9,11）:", "排除行", "")
排除列 = InputBox("请输入不参与统计的列号（用逗号分隔，如:1,2,3,4,9,11）:", "排除列", "")
' 处理排除行列数据
If 排除行 <> "" Then
排除行数组 = Split(排除行, ",")
Else
ReDim 排除行数组(0)
排除行数组(0) = ""
End If
If 排除列 <> "" Then
排除列数组 = Split(排除列, ",")
Else
ReDim 排除列数组(0)
排除列数组(0) = ""
End If
' 4. 遍历所有文件进行累加
计数 = 0
For i = 1 To 文件列表.Count
If 文件列表(i) <> 基表文件名 And 文件列表(i) <> "汇总表.xlsx" Then
' 打开源文件
Workbooks.Open 文件夹路径 & 文件列表(i)
Set 源工作簿 = ActiveWorkbook
' 遍历所有单元格进行累加
For 行号 = 1 To 源工作簿.Sheets(1).UsedRange.Rows.Count
For 列号 = 1 To 源工作簿.Sheets(1).UsedRange.Columns.Count
' 检查是否在排除行列中
If Not 是否排除(行号, 列号, 排除行数组, 排除列数组) Then
' 获取源单元格值
Dim 源值 As Variant
源值 = 源工作簿.Sheets(1).Cells(行号, 列号).Value
' 处理空值
If IsEmpty(源值) Or 源值 = "" Then
源值 = 0
End If
' 累加到汇总表
If IsNumeric(源值) Then
汇总工作簿.Sheets(1).Cells(行号, 列号).Value = _
汇总工作簿.Sheets(1).Cells(行号, 列号).Value + 源值
End If
End If
Next 列号
Next 行号
' 关闭源文件
源工作簿.Close False
计数 = 计数 + 1
End If
Next i
' 5. 表内验证功能
Dim 是否验证 As String
是否验证 = InputBox("是否要进行表内验证？(Y/N)", "表内验证", "N")
If UCase(是否验证) = "Y" Then
' 5.1 行验证规则
Dim 行规则输入 As String
Dim 行规则数组() As String
Dim 行规则计数 As Integer
MsgBox "现在开始录入行验证规则，格式如：5+6+7=9+10+12"
行规则输入 = InputBox("请输入行验证规则（多个规则用分号;分隔）：", "行验证规则")
If 行规则输入 <> "" Then
行规则数组 = Split(行规则输入, ";")
行规则计数 = UBound(行规则数组) + 1
' 验证每个行规则
For i = 0 To UBound(行规则数组)
If Not 验证行规则(汇总工作簿.Sheets(1), 行规则数组(i)) Then
MsgBox "行验证规则 '" & 行规则数组(i) & "' 验证失败！"
End If
Next i
End If
' 5.2 列验证规则
Dim 列规则输入 As String
Dim 列规则数组() As String
Dim 列规则计数 As Integer
MsgBox "现在开始录入列验证规则，格式如：C+D+E=F+H+J"
列规则输入 = InputBox("请输入列验证规则（多个规则用分号;分隔）：", "列验证规则")
If 列规则输入 <> "" Then
列规则数组 = Split(列规则输入, ";")
列规则计数 = UBound(列规则数组) + 1
' 验证每个列规则
For i = 0 To UBound(列规则数组)
If Not 验证列规则(汇总工作簿.Sheets(1), 列规则数组(i)) Then
MsgBox "列验证规则 '" & 列规则数组(i) & "' 验证失败！"
End If
Next i
End If
MsgBox "表内验证完成！共验证了 " & 行规则计数 & " 个行规则和 " & 列规则计数 & " 个列规则。"
End If
' 保存并提示结果
汇总工作簿.Save
MsgBox "统计完成！共累加了 " & 计数 & " 个表格的数据。"
' 激活原始工作簿
当前工作簿.Activate
End Sub
Function 是否排除(行号 As Long, 列号 As Integer, 排除行数组, 排除列数组) As Boolean
Dim i As Integer
是否排除 = False
' 检查行是否排除
For i = 0 To UBound(排除行数组)
If Trim(排除行数组(i)) <> "" And 行号 = CLng(Trim(排除行数组(i))) Then
是否排除 = True
Exit Function
End If
Next i
' 检查列是否排除
For i = 0 To UBound(排除列数组)
If Trim(排除列数组(i)) <> "" And 列号 = CLng(Trim(排除列数组(i))) Then
是否排除 = True
Exit Function
End If
Next i
End Function
Function 验证行规则(工作表 As Worksheet, 规则 As String) As Boolean
Dim 等式两边() As String
Dim 左边部分() As String
Dim 右边部分() As String
Dim 左边和 As Double
Dim 右边和 As Double
Dim i As Integer, j As Integer
' 分割等式两边
等式两边 = Split(规则, "=")
If UBound(等式两边) <> 1 Then
MsgBox "规则格式错误: " & 规则
验证行规则 = False
Exit Function
End If
' 处理左边部分
左边部分 = Split(等式两边(0), "+")
左边和 = 0
For i = 0 To UBound(左边部分)
If IsNumeric(Trim(左边部分(i))) Then
Dim 行号 As Integer
行号 = CInt(Trim(左边部分(i)))
' 计算该行所有数值单元格的和
For j = 1 To 工作表.UsedRange.Columns.Count
If IsNumeric(工作表.Cells(行号, j).Value) Then
左边和 = 左边和 + 工作表.Cells(行号, j).Value
End If
Next j
End If
Next i
' 处理右边部分
右边部分 = Split(等式两边(1), "+")
右边和 = 0
For i = 0 To UBound(右边部分)
If IsNumeric(Trim(右边部分(i))) Then
行号 = CInt(Trim(右边部分(i)))
' 计算该行所有数值单元格的和
For j = 1 To 工作表.UsedRange.Columns.Count
If IsNumeric(工作表.Cells(行号, j).Value) Then
右边和 = 右边和 + 工作表.Cells(行号, j).Value
End If
Next j
End If
Next i
' 比较结果
If Abs(左边和 - 右边和) > 0.001 Then ' 考虑浮点数精度问题
' 标记不匹配的行
For i = 0 To UBound(左边部分)
If IsNumeric(Trim(左边部分(i))) Then
行号 = CInt(Trim(左边部分(i)))
工作表.Rows(行号).Interior.Color = RGB(255, 200, 200) ' 浅红色
End If
Next i
For i = 0 To UBound(右边部分)
If IsNumeric(Trim(右边部分(i))) Then
行号 = CInt(Trim(右边部分(i)))
工作表.Rows(行号).Interior.Color = RGB(255, 200, 200) ' 浅红色
End If
Next i
MsgBox "行验证失败: " & 规则 & vbCrLf & _
"左边和 = " & 左边和 & vbCrLf & _
"右边和 = " & 右边和
验证行规则 = False
Else
验证行规则 = True
End If
End Function
Function 验证列规则(工作表 As Worksheet, 规则 As String) As Boolean
Dim 等式两边() As String
Dim 左边部分() As String
Dim 右边部分() As String
Dim 左边和 As Double
Dim 右边和 As Double
Dim i As Integer, j As Integer
' 分割等式两边
等式两边 = Split(规则, "=")
If UBound(等式两边) <> 1 Then
MsgBox "规则格式错误: " & 规则
验证列规则 = False
Exit Function
End If
' 处理左边部分
左边部分 = Split(等式两边(0), "+")
左边和 = 0
For i = 0 To UBound(左边部分)
Dim 列号 As Integer
列号 = 列字母转数字(Trim(左边部分(i)))
If 列号 > 0 Then
' 计算该列所有数值单元格的和
For j = 1 To 工作表.UsedRange.Rows.Count
If IsNumeric(工作表.Cells(j, 列号).Value) Then
左边和 = 左边和 + 工作表.Cells(j, 列号).Value
End If
Next j
End If
Next i
' 处理右边部分
右边部分 = Split(等式两边(1), "+")
右边和 = 0
For i = 0 To UBound(右边部分)
列号 = 列字母转数字(Trim(右边部分(i)))
If 列号 > 0 Then
' 计算该列所有数值单元格的和
For j = 1 To 工作表.UsedRange.Rows.Count
If IsNumeric(工作表.Cells(j, 列号).Value) Then
右边和 = 右边和 + 工作表.Cells(j, 列号).Value
End If
Next j
End If
Next i
' 比较结果
If Abs(左边和 - 右边和) > 0.001 Then ' 考虑浮点数精度问题
' 标记不匹配的列
For i = 0 To UBound(左边部分)
列号 = 列字母转数字(Trim(左边部分(i)))
If 列号 > 0 Then
工作表.Columns(列号).Interior.Color = RGB(255, 200, 200) ' 浅红色
End If
Next i
For i = 0 To UBound(右边部分)
列号 = 列字母转数字(Trim(右边部分(i)))
If 列号 > 0 Then
工作表.Columns(列号).Interior.Color = RGB(255, 200, 200) ' 浅红色
End If
Next i
MsgBox "列验证失败: " & 规则 & vbCrLf & _
"左边和 = " & 左边和 & vbCrLf & _
"右边和 = " & 右边和
验证列规则 = False
Else
验证列规则 = True
End If
End Function
Function 列字母转数字(列字母 As String) As Integer
' 将列字母转换为列号
列字母转数字 = 0
On Error Resume Next
列字母转数字 = Range(列字母 & "1").Column
On Error GoTo 0
End Function
解决方案说明：
1. 创建一个专门的"工具工作簿"来运行宏：
- 新建一个Excel文件，命名为"报表汇总工具.xlsm"
- 将上述代码复制到该文件的VBA编辑器中
- 每次需要汇总时，打开这个工具工作簿运行宏
2. 代码中的改进：
- 添加了对当前工作簿的引用和检查
- 防止用户选择当前工作簿作为基表
- 处理完成后会重新激活原始工作簿
3. 使用步骤：
- 打开"报表汇总工具.xlsm"
- 运行"独立汇总工具"宏
- 按照提示选择文件夹和基表文件
- 宏会在后台处理所有文件，包括原本打开的123.xlsx
这样，您就可以在保持123.xlsx打开的同时，让它参与汇总统计了。工具工作簿只是作为一个控制器，不会干扰实际的数据文件。
以上回复来自 FishC AI 小助理，如未能正确解答您的问题，请继续追问。 |
|
( 粤ICP备18085999号-1 | 粤公网安备 44051102000585号)
狗仔卡
发表于 
置顶卡
千斤顶
显身卡
发表于 
楼主