將EXCEL資料分開

  &nbspA(姓名)   B(日期)   C(上班時間)   D(下班時間)

1    aaa        1/1           08:00            18:00
2    aaa        1/2           08:10            18:10
3    aaa        1/3           08:29            18:01
.
.
.
X    aaa       1/31          08:20            18:18
X    bbb        1/1           08:09            17:59
X    bbb        1/2           08:19            17:09
X    bbb        1/3           08:22            17:39
.
.
.
X    bbb       1/31          08:21            18:11
X    ccc        1/1           08:26            17:38
X    ccc        1/2           08:06            17:40
X    ccc        1/3           08:18            18:47
.
.
.
--------------------------------------------------------------
這些資料都集中在同一個sheet中，想把他們用不同的sheet分開，或有什麼方法能分開列印
我們有好幾十個人，每一次都只能將每一個人的抓出來，分開列印，再發給他們每一個人
求大大協助，謝謝^^

2017-02-03 15:43 #1

文章關鍵字

excel 資料

Yu_Feng

101分

2樓

Yu_Feng

個人積分：101分

文章編號：63231519

使用篩選功能，要列印時，選擇需要的，如aaa，列印時就可以只印出aaa

snare

3221分

3樓

snare

個人積分：3221分

文章編號：63233105

會回答您，只是因為我曾經回答過同樣的問題，不過我忘了是那一篇。
程式碼也是以前寫的，只有稍微整理一下…

程式的列印功能請自己加上去，不會vba的話，請用“錄製巨集”練習一下
列印所有工作表，只需要再多加“一行”程式碼而己

如果連錄製巨集也不會，那請改用“手動列印”吧
最麻煩的自動分類幫您處理好了，其它不解釋


'程式功能
'根據 工作表1(a欄)的資料(不需排序)，自動篩選分類後，再把各項分類，複製到新工作表
'如果該欄位的資料是日期、時間，需調整Name_Data變數的格式，否則無法正常篩選
Sub test()

    Call delsheet '只保留工作表1，刪掉其它所有工作表
    Dim temparray() As Variant, All_Criteria, Name_Data, i As Integer, Col As String
    
    Col = "a" '預設a欄

    With Sheets("工作表1")
        .Range(Col & ":" & Col).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        Set All_Criteria = .Range(Col & "2", .Range(Col & Rows.Count).End(xlUp)).SpecialCells(12)
        ReDim temparray(1 To All_Criteria.Count)
    
        For Each Name_Data In All_Criteria
            i = i + 1: temparray(i) = Name_Data
        Next
   
        For Each Name_Data In temparray
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = "_" & Name_Data & "_"
            .Range(Col & ":" & Col).AutoFilter Field:=1, Criteria1:=Name_Data
            .UsedRange.Copy Sheets("_" & Name_Data & "_").Cells(1, 1)
        Next

        .AutoFilterMode = False
        
    End With

End Sub

Sub delsheet()

    Dim delsheet() As Variant, i As Integer, j As Integer
    ReDim delsheet(1 To Worksheets.Count)
    Application.DisplayAlerts = False
    
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name <> "工作表1" Then '預設不刪除工作表1
            j = j + 1
            delsheet(j) = Worksheets(i).Name
        End If
    Next
    If j = 0 Then Exit Sub
    ReDim Preserve delsheet(1 To j)
    Worksheets(delsheet).Delete
    
    Application.DisplayAlerts = True

End Sub