Board logo

標題: [發問] Sheet中的值,依A欄中的部門複製至新的Sheet [打印本頁]
作者: JH8888    時間: 2012-2-14 15:54     標題: Sheet中的值,依A欄中的部門複製至新的Sheet

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

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

以上還煩請各位高手幫忙解惑!
謝謝!
作者: GBKEE    時間: 2012-2-14 18:09

回復 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    時間: 2012-2-15 04:45

本帖最後由 JH8888 於 2012-2-15 10:05 編輯

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

好久沒來這裡了啊,連帳號都要重來了啊!
這裡仍是VBA交流的首選.:)
作者: GBKEE    時間: 2012-2-15 08:08

回復 3# JH8888
看到你附檔的 Sub Copy_Every_Sheet_To_New_Workbook()
我很好奇,你可以自己寫為何還要發問!
作者: JH8888    時間: 2012-2-15 10:18

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

a very good practice for beginner like me. Thx
作者: hugh0620    時間: 2012-2-15 14:58

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)