拆分工作表

excelsudel

问老师这个问题，请看附件，谢谢！

excelsudel

要用VBA做啊！

lsc900707

excelsudel 发表于 2019-8-16 20:08
要用VBA做啊！

学会“评分”，解答的人就多了。

donghui2363

写了一个挺啰嗦的
Sub 拆分()
Dim wd As Workbook
r = [a65536].End(xlUp).Row
arr = Range("a1:c" & r)
ReDim brr(1 To 50, 1 To 3)
ReDim crr(1 To 50, 1 To 3)
ReDim drr(1 To 50, 1 To 3)
b = 1: c = 1: d = 1
    For i = 2 To UBound(arr)
        m = Format(arr(i, 1), "m")
    Select Case m
    Case 1
        b = b + 1
        For j = 1 To UBound(arr, 2)
            brr(1, j) = arr(1, j)
            brr(b, j) = arr(i, j)
        Next j
    Case 2
        c = c + 1
        For j = 1 To UBound(arr, 2)
            crr(1, j) = arr(1, j)
            crr(c, j) = arr(i, j)
        Next j
    Case 3
        d = d + 1
        For j = 1 To UBound(arr, 2)
            drr(1, j) = arr(1, j)
            drr(d, j) = arr(i, j)
        Next j
    End Select
    Next i
   Set wd = Workbooks.Add
   wd.Sheets(1).Range("a1").Resize(b, 3) = brr
   ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "1月" & ".xlsx"
   wd.Close False
   Set wd = Workbooks.Add
   wd.Sheets(1).Range("a1").Resize(c, 3) = crr
   ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "2月" & ".xlsx"
   wd.Close False
   Set wd = Workbooks.Add
   wd.Sheets(1).Range("a1").Resize(d, 3) = drr
   ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "3月" & ".xlsx"
   wd.Close False
End Sub

lsc900707

Sub gj23w98()
    Application.ScreenUpdating = False
    arr = [a1].CurrentRegion
    r = UBound(arr): c = UBound(arr, 2)
    Set rng = [a1].Resize(1, c)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To r
        s = Month(arr(i, 1))
         If Not d.exists(s) Then
                Set d(s) = Cells(i, 1).Resize(1, c)
            Else
                Set d(s) = Union(d(s), 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
        With wb.Sheets(1)
            rng.Copy .[a1]: t(i).Copy .[a2]
            For j = 1 To UBound(arr, 2)
               .Columns(j).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(j).ColumnWidth
            Next
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & "月"
        wb.Close
    Next
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

lsc900707

测试参考附件：

everbest2015

Sub chaifen()
    Dim sh As Worksheet, wb As Workbook, wkb As Workbook, path$, ar, d As Object, i&, s$, yue$, k
    Set wb = ThisWorkbook
    Set sh = wb.Sheets("产销量")
    path = wb.path & "\"
    With sh
        If .AutoFilterMode Then .AutoFilterMode = False
        ar = .Range("a1").CurrentRegion
        Set d = CreateObject("scripting.dictionary")
    End With
    With sh
        For i = 2 To UBound(ar)
            s = ar(i, 1)
            If s <> "" Then
                yue = Month(CDate(s))
                If d.exists(yue) = False Then
                    Set d(yue) = .Range("a" & i).Resize(, 3)
                Else
                    Set d(yue) = Union(d(yue), .Range("a" & i).Resize(, 3))
                End If
            End If
        Next
    End With
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
        If d.Count > 0 Then
            For Each k In d.keys
                Set wkb = Workbooks.Add
                With wkb
                    Set sh = .Sheets(1)
                    With sh
                        .[a1:c1] = Array("日期", "产量", "销量")
                        d(k).Copy .Range("a2")
                        .UsedRange.HorizontalAlignment = xlCenter
                        .UsedRange.VerticalAlignment = xlCenter
                        .UsedRange.EntireColumn.AutoFit
                        .UsedRange.Borders.LineStyle = xlContinuous
                    End With
                    .SaveAs Filename:=path & k & ".xlsx"
                    .Close True
                End With
            Next
            
        End If
    Application.ScreenUpdating = True: Application.DisplayAlerts = True
    MsgBox "共拆分出" & d.Count & "个工作簿", vbInformation, "提示"

End Sub

everbest2015

代码在审核   先上个图