根据A列筛选结果另存为新的工作簿

chengcaizilu

此表特殊地方：1：每列均没有字段名称   2：有些列是空白的 3：另存为的结果最好是xls格式 （原始文件是xlsx格式） 4：另存为工作簿名称需要以其内容命名 希望有路过的大神帮忙看看，感激不尽！

lsc900707

Sub gj23w98()
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     r = ActiveSheet.UsedRange.Rows.Count: c = ActiveSheet.UsedRange.Columns.Count
     arr = Cells(1, 1).Resize(r, c)
     Set d = CreateObject("scripting.dictionary")
     For i = 1 To UBound(arr)
          If Not d.exists(arr(i, 1)) Then
                 Set d(arr(i, 1)) = Cells(i, 1).Resize(1, c)
             Else
                 Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, c))
          End If
     Next
     k = d.keys: t = d.items
     For i = 0 To d.Count - 1
         Set wb = Workbooks.Add(xlWBATWorksheet)
         With wb.Sheets(1)
             t(i).Copy .[a1]
         End With
         wb.SaveAs Filename:=ThisWorkbook.Path & "\结果\" & k(i), FileFormat:=xlExcel8
         wb.Close
     Next
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox "完毕"
End Sub

lsc900707

直接按A列拆分工作表另存工作簿就好。
代码已提交，待审核。

chengcaizilu

lsc900707 发表于 2018-1-5 12:58
直接按A列拆分工作表另存工作簿就好。
代码已提交，待审核。

非常感谢版主的帮助

chengcaizilu

chengcaizilu 发表于 2018-1-5 18:09
非常感谢版主的帮助

版主你好，如果每列都有表头字段（如姓名   年龄  ），结果表里也需要表头字段保留。代码改如何修改。谢谢！