[發問] Sheet中的值,依A欄中的部門複製至新的Sheet

JH8888

請問各位,有那位可以幫幫忙.

問題:我有一個sheet中要依部門資料,自動拆分成多個sheet或多個xls
     其中資料是以部門排序,相同的部門需產生sheet或一個xls(檔名依部門名稱命名)

以上還煩請各位高手幫忙解惑!
謝謝!

GBKEE

回復 1# JH8888

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, S As String, xi As Integer
   
4.     Application.DisplayAlerts = False                                          ' Microsoft Excel 顯示特定的警告和訊息則為 True。讀/寫 Boolean
   
5.     Application.ScreenUpdating = False                                         '如果螢幕更新功能是開啟的則為 True。讀/寫 Boolean。
   
6.     With Sheets("Sheet1")
   
7.         For xi = Sheets.Count To 1 Step -1
   
8.             If Sheets(xi).Name <> .Name Then Sheets(xi).Delete                  '刪除 原有檔案 須由後往前刪
   
9.         Next
   
10.         If .AutoFilterMode Then .AutoFilterMode = False                         '取消篩選
    
11.         .Range("a1").AutoFilter                                                 '[自動篩選] 篩選出一個清單
    
12.         Set Rng = .AutoFilter.Range.Columns(1).Cells                            '[自動篩選]的第1欄
    
13.         For xi = 2 To Rng.Count                                                  '處裡:  第1欄
    
14.             If InStr(S, "," & Rng(xi) & ",") = False Then                        '檢查  是否已出現過
    
15.             .Range("a1").AutoFilter Field:=1, Criteria1:=Rng(xi)                 '沒出現: 指定為篩選值
    
16.             S = S & "," & Rng(xi) & ","                                          '加入已出現過的字串中
    
17.             Sheets.Add , Sheets(Sheets.Count)                                   '新增一工作表
    
18.             ActiveSheet.Name = Rng(xi)                                           '命名:篩選值
    
19.             .UsedRange.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.[a1]    '複製: 資料表中篩選出的資料 ->新工作表的[A1]
    
20.             ActiveSheet.Cells.Columns.AutoFit                                   'AutoFit: 將範圍中的欄寬和列高調整為最適當的值。
    
21.             End If
    
22.         Next
    
23.         .AutoFilterMode = False                                                  '取消篩選
    
24.         .Activate                                                                '回到 資料表
    
25.     End With
    
26.     Application.ScreenUpdating = True
    
27.     Application.DisplayAlerts = True
    
28. End Sub

複製代碼

JH8888

多謝版主解救,學習了,把巨集加入了,並加上可以轉存成個別xls
感謝!

好久沒來這裡了啊,連帳號都要重來了啊!
這裡仍是VBA交流的首選.:)

GBKEE

回復 3# JH8888
看到你附檔的 Sub Copy_Every_Sheet_To_New_Workbook()
我很好奇,你可以自己寫為何還要發問!

JH8888

我本身對VBA算是初級班,程式碼大約看的懂,
有一陣子沒碰VBA了,只是剛好有這個功能的需求,google蒐了一下沒什麼類似的,
如果有找到類似的我改改還可以,但要新建就有點困難,
剛好又蒐到這個網站,才發現我曾經在這註冊過,但舊帳號似乎錯過轉換期了啊!
VBA的指令部份仍不太熟悉,還很多要學習的地方,
另外那個功能也是在google蒐到的,並把他加入分享給其他如有需要的人可以一起用.
感謝你熱心的回復.

felixchi

a very good practice for beginner like me. Thx

hugh0620

以前我也有問過相類似的問題~ 也是G大大幫忙協助解惑~
自己也依此自行修改~ 完成該工作~
提供給您參考~
http://forum.twbts.com/viewthread.php?tid=2855&highlight=