vba批量新建多个工作簿

如何用vba将excel内容根据某列内容批量新建多个工作簿        注意：这列有重复值

  注意修改参考的工作表及所在列，效果如下，帮助到你能点个采纳吗，谢谢~

Sub createSheet()
  excelpath = "F:\vba\通过某列内容建立工作簿\"'工作簿保存位置
  rownum = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).row '注意修改这里，参考的工作表和列，现在是Sheet1 A列
  Application.ScreenUpdating = False
  For i = 1 To rownum
    fn = excelpath & ThisWorkbook.Sheets(1).Cells(i, "A") & ".xlsx"
    If Len(Dir(fn)) = 0 Then '文件不存在
      Workbooks.Add
      ActiveWorkbook.SaveAs Filename:=fn, FileFormat:=xlOpenXMLWorkbook
      ActiveWindow.Close
    End If
  Next
  Application.ScreenUpdating = True
 
End Sub

Sub test()
Dim dic As New Dictionary
Dim arr
Dim i As Integer
Dim rng As Range
Dim rg As Range
Dim startrow, startcolum, endrow, endcolumn As Integer
On Error GoTo 100
Set rng = Application.InputBox("请选择生成的表所在列", "区域", , , , , , 8)
startrow = rng.Row
startcolumn = rng.Column
endrow = Application.CountA(rng)
endcolumn = rng.Column
diccolumn = rng.Columns.Count
arr = Range(Cells(startrow, startcolumn), Cells(endrow, endcolumn))
For i = startrow To endrow
dic(arr(i, diccolumn)) = ""
Next i
Set rg = Application.InputBox("选择存放区域", "选择存放单元格", , , , , , 8)
rg.Resize(dic.Count, diccolumn) = Application.Transpose(dic.Keys)
For Each ss In rg
If ss.Value = "" Then
GoTo 100
End If
Application.ScreenUpdating = False
Worksheets.Add.Name = ss.Value
Next ss
str = ThisWorkbook.Path
newfolder = str & "\通过某列内容建立工作簿"
Isfolder = VBA.Dir(newfolder, vbDirectory)
If Isfolder = "" Then
MkDir newfolder
For Each sht In ThisWorkbook.Sheets
With sht
.UsedRange.Value = .UsedRange.Value
.Copy
End With
With ActiveWorkbook
.SaveAs newfolder sht.Name & ".xls", FileFormat:=xlWorkbookNormal
.Close
End With
Application.DisplayAlerts = False
sht.Delete
End If
Next sht
Application.ScreenUpdating = True
End If
100
End Sub