拆成多工作簿多工作表通用版

hefuqing

Sub 拆成多工作簿多工作表()
Application.DisplayAlerts = False
Dim ARR, brr()
bkk = Application.InputBox("请输入拆分工作簿所在列:", "工作簿所在列", "A", Type:=2)
If bkk = "" Then Exit Sub
shh = Application.InputBox("请输入拆分工作表所在列:", "工作表所在列", "E", Type:=2)
If shh = "" Then Exit Sub
bk = Cells(1, bkk).Column
sh = Cells(1, shh).Column
Set Rngh = Rows(1) '标题
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
ARR = [A1].CurrentRegion '数据写入数组
  For i = 2 To UBound(ARR)
  d1(Replace(ARR(i, bk), Chr(9), "")) = "" '第bk列去重
  d2(Replace(ARR(i, sh), Chr(9), ""))= "" '第sh列去重
  Next
k1 = d1.Keys '第bk列去重后的集合
k2 = d2.Keys '第sh列去重后的集合

For i = 0 To d1.Count - 1
  With Workbooks.Add(xlWBATWorksheet) '按照第2列新建工作簿
    If k1(i) = "" Then
       .SaveAs Filename:=ThisWorkbook.Path & "\" & "空值" & ".xlsx" '另存为工作簿并命名
  Else
    .SaveAs Filename:=ThisWorkbook.Path & "\" & k1(i) & ".xlsx" '另存为工作簿并命名
    End If
  End With

      For j = 0 To d2.Count - 1
         For k = 2 To UBound(ARR)
             If Replace(ARR(k, bk), Chr(9), "")  = k1(i) And Replace(ARR(k, sh), Chr(9), "")   = k2(j) Then '筛选满足第bk列和第sh列条件的数据
               n = n + 1
               ReDim Preserve brr(1 To UBound(ARR, 2), 1 To n)
                  For m = 1 To UBound(ARR, 2)
                       brr(m, n) =Replace( ARR(k, m), Chr(9), "")   '写入数组brr
                  Next m
              End If
         Next k
         If n > 0 Then
               If k2(j) = "" Then
                  Sheets.Add.Name = "空值"
               Else
                  Sheets.Add.Name = k2(j) '新增工作表
               End If
             Rngh.Copy ActiveSheet.Range("A1") '把标题写入第一行
             ActiveSheet.Columns("a:z").NumberFormat = "@"
             ActiveSheet.Range("A2").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
             Erase brr
             n = 0
          End If
    Next j
    Sheets("sheet1").Delete
    ActiveWorkbook.Close True '关闭保存
Next i
Set d1 = Nothing
Set d2 = Nothing
Application.DisplayAlerts = True
End Sub

lsc900707

没有绝对通用的方案。