按某一列（相同内容排序放在一起）切分表格，另存为单独工作簿

'按某一列切分表格，另存为单独工作簿

Sub Qf()

 

 Dim i, m, n As Integer

 Dim arr, arr1

 Dim wb As Workbook

 Dim Rng As Range

 Dim Str As String

 Dim x As Integer

   

 Set d = CreateObject("Scripting.Dictionary")

 

 arr = Range("b2").Resize(Range("b1048576").End(xlUp).Row - 1, 1)  '第二列除表头之外的非空数据，赋给数组arr（列值随时修改）

   

        For i = 1 To UBound(arr)   '给字典填值,取出非重复的值

              d(arr(i, 1)) = ""

        Next

   

 arr1 = d.Keys  '字典的key赋给一维数组

   

 t = Timer

 Application.ScreenUpdating = False

   

 x = 2

        For n = 1 To d.Count

                    

                Set wb = Application.Workbooks.Add

                                        

                Sheet1.Cells(1, "A").Resize(1, 5).Copy wb.Sheets(1).Range("A1")    '复制表头到分表(列数随时修改)

                                        

               

                Str = Sheet1.Cells(x, "b").Value                                   '(列值随时修改)

                

                    For m = x To UBound(arr) + 1                                        '将满足要求的各行，复制到新工作簿里面

                        If Str = arr1(n - 1) Then

                            Set Rng = wb.Sheets(1).Range("a1048576").End(xlUp).Offset(1, 0)   '定位最下面的空白输入位置

                            Sheet1.Cells(m, "A").Resize(1, 5).Copy Rng              '复制,(列数随时修改)

                            x = x + 1

                        End If

                        Str = Sheet1.Cells(x, "b").Value

                    Next

                    

                wb.Sheets(1).Columns("a:az").AutoFit                                  '根据内容调整列宽

                wb.SaveCopyAs ThisWorkbook.Path & "\" & arr1(n - 1) & ".xlsx"          '另存为新工作簿，并重新命名

                wb.Close False

                

        Next

           

 Application.ScreenUpdating = True

 

 MsgBox Timer - t

    

 End Sub