|
|
楼主 |
发表于 2024-8-27 22:23
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
以下是ai智障写的代码，循环第二次就出错：Sub SplitSheetByTemplate()
Dim ws As Worksheet
Dim templateSheet As Worksheet
Dim wbNew As Workbook
Dim dict As Object
Dim lastRow As Long
Dim lastCol As Long
Dim fileNameCol As Long
Dim sheetNameCol As Long
Dim cell As Range
Dim key As Variant
Dim keys() As String
Dim i As Long
Dim mapping As Variant
' 设置源工作表和模板工作表
Set ws = ThisWorkbook.Sheets("Sheet1") ' 请将 "Sheet1" 更改为实际的源工作表名称
Set templateSheet = ThisWorkbook.Sheets("Template") ' 请将 "Template" 更改为实际的模板工作表名称
' 获取最后一行和最后一列
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' 创建字典存储唯一的关键字组合
Set dict = CreateObject("Scripting.Dictionary")
' 获取用户输入的文件名和工作表名列索引
fileNameCol = Application.InputBox("请输入工作簿名所在列的索引（例如 A=1, B=2 等）:", Type:=1)
sheetNameCol = Application.InputBox("请输入工作表名所在列的索引（例如 A=1, B=2 等）:", Type:=1)
' 获取用户输入的映射关系
ReDim mapping(1 To lastCol)
For i = 1 To lastCol
Dim userInput As String
userInput = Application.InputBox("请输入源表格列 " & ws.Cells(1, i).Address & " 在模板中的位置（例如 B5 表示将此列内容放到模板的 B5）:", Type:=2)
If userInput <> "" Then
mapping(i) = userInput
Else
mapping(i) = "" ' 如果用户没有输入，则将映射为空
End If
Next i
' 循环遍历行，添加唯一的关键字组合到字典中
For Each cell In ws.Range(ws.Cells(2, fileNameCol), ws.Cells(lastRow, fileNameCol))
If Not dict.exists(cell.Value & "|" & cell.Offset(0, sheetNameCol - fileNameCol).Value) And cell.Value <> "" And cell.Offset(0, sheetNameCol - fileNameCol).Value <> "" Then
dict.Add cell.Value & "|" & cell.Offset(0, sheetNameCol - fileNameCol).Value, cell.Row
End If
Next cell
' 循环处理每个唯一关键字，创建新的工作簿和工作表
For Each key In dict.keys
keys = Split(key, "|")
Dim fileName As String
Dim sheetName As String
fileName = keys(0) ' 工作簿名
sheetName = keys(1) ' 工作表名
' 检查工作簿是否已存在
On Error Resume Next
Set wbNew = Workbooks(fileName & ".xlsx")
On Error GoTo 0
If wbNew Is Nothing Then
' 如果工作簿不存在，则新建一个工作簿
Set wbNew = Workbooks.Add
' 删除默认工作表
Application.DisplayAlerts = False
Do While wbNew.Sheets.Count > 0
wbNew.Sheets(1).Delete
Loop
Application.DisplayAlerts = True
' 添加新工作表
templateSheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = sheetName
Else
' 如果工作簿已存在，则添加新的工作表
templateSheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = sheetName
End If
' 将当前行的数据根据映射关系复制到新工作表
Dim sourceRow As Long
sourceRow = dict(key)
For i = 1 To lastCol
If mapping(i) <> "" Then
' 将源表格中的数据放置到新工作表中的指定位置
wbNew.Sheets(sheetName).Range(mapping(i)).Value = ws.Cells(sourceRow, i).Value
End If
Next i
' 保存并关闭新工作簿
wbNew.SaveAs ThisWorkbook.Path & "\" & fileName & ".xlsx"
wbNew.Close SaveChanges:=True
Next key
' 提示用户过程已完成
MsgBox "表格已根据指定的关键字拆分并保存为多个工作簿。", vbInformation
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-8-27 22:21
