请问我想将excel的数据按要求拆分成多个sheet

weihebunen

如表数据，要按车型拆分多个sheet，要放在同一份表后面的sheet，不是独立一个excel文件。之前用方方格子就有功能可以用，但是试用期过后就要收费了，我又每个月都要用，请各位老师教导一下，谢谢。

weihebunen

求问各大神

orr89

Sub 分表()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim dic
    Set dic = CreateObject("scripting.dictionary")

    arr = Range("a1").CurrentRegion
    For a = 2 To UBound(arr)
        If Not dic.exists(arr(a, 1)) Then
            dic(arr(a, 1)) = a
        Else
            dic(arr(a, 1)) = dic(arr(a, 1)) & "@" & a
        End If
    Next

    现在有几个表 = Sheets.Count
    If 现在有几个表 > 1 Then
        For a = 现在有几个表 To 2 Step -1
            Worksheets(a).Delete
        Next
    End If

    For a = 1 To dic.Count
        那些行 = Split(dic.items()(a - 1), "@")
        For b = 0 To UBound(那些行)
            Set Rng = Range(Cells(那些行(b), "a"), Cells(那些行(b), "l"))
            n = n + 1
            If n = 1 Then Set rngs = Rng Else Set rngs = Union(rngs, Rng)
        Next
            Sheets.Add after:=Worksheets(a)
            ActiveSheet.Name = dic.keys()(a - 1)
            Sheet1.Activate
            rngs.Copy
            Sheets(dic.keys()(a - 1)).Activate
            [a1].Resize(1, 10) = Array("车型", "卡号", "入场日期", "出场日期", "维修分类", "维修场地", "班组", "报修内容", "维修经过", "完工总时间", "主修人", "检验员")
            Range("a2").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
            n = 0: Set Rng = Nothing: Set rngs = Nothing: Sheet1.Activate
    Next


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
仅供参考

weihebunen

orr89 发表于 2020-2-26 15:23
Sub 分表()

    Application.ScreenUpdating = False

多谢，我试试

weihebunen

orr89 发表于 2020-2-26 15:23
Sub 分表()

    Application.ScreenUpdating = False

感谢帮忙

weihebunen

orr89 发表于 2020-2-26 15:23
Sub 分表()

    Application.ScreenUpdating = False

你好，请问我想按车号来分sheet怎么改呢

orr89

        If Not dic.exists(arr(a, 1)) Then
            dic(arr(a, 1)) = a
        Else
            dic(arr(a, 1)) = dic(arr(a, 1)) & "@" & a
        End If

改数字，自己数车号是第几列

18348693642

Sub 整理()
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A2:A1202" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:L1202")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Set a = Worksheets("Sheet1")
n = a.Cells(100000, 1).End(xlUp).Row
p = 1
For i = 2 To n
    If a.Cells(i, 1) <> a.Cells(i + 1, 1) Then
        Set k = Worksheets.Add(after:=Worksheets("Sheet1"))
        k.Name = a.Cells(i, 1)
        a.Range(a.Cells(1, 1), a.Cells(1, "l")).Copy k.Cells(1, 1)
        a.Range(a.Cells(p + 1, 1), a.Cells(i, "l")).Copy k.Cells(2, 1)
        p = i
    End If
Next
End Sub

sheeboard

用pandas,参考

1. import pandas as pd
   
2. df=pd.read_excel('test.xlsx',dtype={'入场日期':str,'出场日期':str})
   
3. writer=pd.ExcelWriter('result.xlsx')
   
4. grouped=df.groupby('车型')
   
5. 
   
6. for i,j in grouped:
   
7.     j.to_excel(writer,i,index=False)
   
8. writer.save()
   

复制代码

weihebunen

多谢锦多位指教