最火的AI写的代码，请大神改错

·遁去的一· · 发表于 2023-5-16 23:38

用AI写的代码，作用是根据当前列的内容拆分工作表为多个单独文件。具体如下：

Sub SplitSheetByColumn()
'获取当前选定区域所在的列号
Dim categoryCol As Integer
categoryCol = Selection.Column
'获取数据范围
Dim lastRow As Long
lastRow = Cells(Rows.Count, categoryCol).End(xlUp).Row
Dim dataRange As Range
Set dataRange = Range(Cells(1, 1), Cells(lastRow, Columns.Count).End(xlToLeft))
'创建字典对象并遍历数据范围
Dim categoryDict As Object
Set categoryDict = CreateObject("Scripting.Dictionary")
categoryDict.CompareMode = vbTextCompare
Dim cell As Range
For Each cell In dataRange.Columns(categoryCol)
<font color="#ff0000"> If Not categoryDict.Exists(cell.Value) Then</font>
categoryDict.Add cell.Value, cell.Row
End If
Next cell
'创建新工作簿并拆分数据
Dim wb As Object
Set wb = CreateObject("Excel.Application").Workbooks.Add
Dim category As Variant
For Each category In categoryDict.Keys
Dim newSheet As Object
Set newSheet = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
newSheet.Name = category
Dim startIndex As Long
startIndex = categoryDict.Item(category)
Dim endIndex As Long
If categoryDict.Exists(categoryDict.Keys()(categoryDict.Keys().IndexOf(category) + 1)) Then
endIndex = categoryDict.Item(categoryDict.Keys()(categoryDict.Keys().IndexOf(category) + 1)) - 1
Else
endIndex = lastRow
End If
dataRange.Rows(startIndex & ":" & endIndex).Copy newSheet.Range("A1")
Next category
'保存并关闭新工作簿
Dim fileName As String
fileName = ThisWorkbook.Path & "" & "拆分结果.xlsx"
wb.SaveAs fileName
wb.Close SaveChanges:=False
'清除对象引用
Set wb = Nothing
Set categoryDict = Nothing
'显示消息框
MsgBox "已成功拆分为多个工作簿并保存到" & fileName, vbInformation
End Sub

复制代码

出现问题的是：If Not categoryDict.Exists(cell.Value) Then 这句，提示错误代码5。
请教各位大神指点一下不太聪明的AI

·遁去的一· · 发表于 2023-5-16 23:39

不知道是不是字典定义那出现问题导致的

佳能lT搬砖着 · 发表于 2023-5-17 00:14

·遁去的一· 发表于 2023-5-16 23:39
不知道是不是字典定义那出现问题导致的

您的问题可能是：Scripting.Dictionary 在此计算机上没有启用。您可以尝试添加 Microsoft Scripting Runtime 引用。
Sub SplitSheetByColumn()
'获取当前选定区域所在的列号
Dim categoryCol As Integer
categoryCol = Selection.Column

'获取数据范围
Dim lastRow As Long
lastRow = Cells(Rows.Count, categoryCol).End(xlUp).Row
Dim dataRange As Range
Set dataRange = Range(Cells(1, 1), Cells(lastRow, Columns.Count).End(xlToLeft))

'创建字典对象并遍历数据范围
Dim categoryDict As Scripting.Dictionary '修改1：用Scripting.Dictionary替换Object类型
Set categoryDict = New Scripting.Dictionary '修改2：使用New关键字创建对象
categoryDict.CompareMode = vbTextCompare

Dim cell As Range
For Each cell In dataRange.Columns(categoryCol)
      If Not categoryDict.Exists(cell.Value) Then
         categoryDict.Add cell.Value, cell.Row
      End If
Next cell

'创建新工作簿并拆分数据
Dim wb As Workbook '修改3：用Workbook代替Object类型
Set wb = Workbooks.Add

Dim category As Variant
For Each category In categoryDict.Keys
      Dim newSheet As Worksheet '修改4：用Worksheet代替Object类型
      Set newSheet = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
      newSheet.Name = category

      Dim startIndex As Long
      startIndex = categoryDict.Item(category)
      Dim endIndex As Long
      If categoryDict.Exists(categoryDict.Keys()(categoryDict.Keys().IndexOf(category) + 1)) Then
         endIndex = categoryDict.Item(categoryDict.Keys()(categoryDict.Keys().IndexOf(category) + 1)) - 1
      Else
         endIndex = lastRow
      End If

      dataRange.Rows(startIndex & ":" & endIndex).Copy newSheet.Range("A1")
Next category

'保存并关闭新工作簿
Dim fileName As String
fileName = ThisWorkbook.Path & "" & "拆分结果.xlsx"
wb.SaveAs fileName
wb.Close SaveChanges:=False

'清除对象引用
Set wb = Nothing
Set categoryDict = Nothing

'显示消息框
MsgBox "已成功拆分为多个工作簿并保存到" & fileName, vbInformation
End Sub
注意：您需要将本代码中的可选行号31-32之间的引号删除。这些引号是用于Markdown代码主题的格式化。

zpy2 · 发表于 2023-5-17 07:59

佳能lT搬砖着发表于 2023-5-17 00:14
您的问题可能是：Scripting.Dictionary 在此计算机上没有启用。您可以尝试添加 Microsoft Scripting Runt ...

Set categoryDict = CreateObject("Scripting.Dictionary")
如果是mac机器，这行就报错了，建议楼主上传附件方便大家沟通

WANT-T · 发表于 2023-5-17 09:18

谁写的找谁帮你改，这是规矩

·遁去的一· · 发表于 2023-5-17 14:25

佳能lT搬砖着发表于 2023-5-17 00:14
您的问题可能是：Scripting.Dictionary 在此计算机上没有启用。您可以尝试添加 Microsoft Scripting Runt ...

已引用，也试过楼主的这种方式，结果还是一样的

·遁去的一· · 发表于 2023-5-17 14:28

zpy2 发表于 2023-5-17 07:59
Set categoryDict = CreateObject("Scripting.Dictionary")
如果是mac机器，这行就报错了，建议楼主 ...

这是ChatGPT自动生成的通用代码，放入任何文件的模块里就可以用了，没必要上传吧

·遁去的一· · 发表于 2023-5-17 14:30

WANT-T 发表于 2023-5-17 09:18
谁写的找谁帮你改，这是规矩

规矩我知道啊，但ChatGpt有点傻啊，改了无数次都没解决

·遁去的一· · 发表于 2023-5-17 15:59

这个是可以运行的代码，还是AI改的，需要的

Dim ws As Worksheet
Dim data As Variant
Dim uniqueValues As Object
Dim currentColumn As Range
Dim currentValue As Variant
Dim NewWorkbook As Workbook
Dim newWorksheet As Worksheet
Dim FileName As String
Dim i As Long, j As Long
Dim rowCount As Long, colCount As Long
' 设置要拆分的表格工作表
Set ws = ThisWorkbook.Worksheets("Sheet1") ' 修改为你的工作表名称
' 获取当前列
Set currentColumn = Selection
' 获取数据范围
rowCount = ws.Cells(ws.Rows.Count, currentColumn.Column).End(xlUp).Row ' 获取行数
colCount = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column ' 获取列数
data = ws.Range(ws.Cells(1, 1), ws.Cells(rowCount, colCount)).Value ' 将数据加载到数组
' 创建字典来存储唯一值
Set uniqueValues = CreateObject("Scripting.Dictionary")
' 遍历列中的每个单元格，将唯一值添加到字典中
For i = 1 To rowCount
uniqueValues(data(i, currentColumn.Column)) = 1
Next i
' 循环遍历唯一值
For Each currentValue In uniqueValues.keys
' 创建一个新的工作簿并复制原始工作表
Set NewWorkbook = Workbooks.Add
Set newWorksheet = NewWorkbook.Sheets(1)
newWorksheet.Name = "Sheet1"
' 复制标题行及格式
ws.Rows(1).Copy Destination:=newWorksheet.Rows(1)
' 复制符合当前唯一值的行及格式
j = 2 ' 从第二行开始复制数据
For i = 1 To rowCount
If data(i, currentColumn.Column) = currentValue Then
ws.Rows(i).Copy Destination:=newWorksheet.Rows(j)
j = j + 1
End If
Next i
' 保存新工作簿并关闭
FileName = "Split_" & currentValue & ".xlsx" ' 设置文件名
NewWorkbook.SaveAs FileName
NewWorkbook.Close SaveChanges:=False
Next currentValue
' 提示完成信息
MsgBox "拆分完成！"
End Sub

复制代码

拿去吧

准提部林 · 发表于 2023-5-17 20:37

·遁去的一· 发表于 2023-5-17 14:28
这是ChatGPT自动生成的通用代码，放入任何文件的模块里就可以用了，没必要上传吧

這裡倒多了一個..給GPT改錯的用處~~
上傳附件及規則...保證大家都重寫!!!

左看右看...這代碼並不通用~~~

		自动登录	找回密码
密码			免费注册

[求助] 最火的AI写的代码，请大神改错