Board logo

標題: [發問] 1張主工作表篩選後新增工作表及命名 [打印本頁]
作者: missbb    時間: 2018-6-8 23:24     標題: 1張主工作表篩選後新增工作表及命名

sub copyfile()
'將DATA工作表內按部門篩選後另存工作表
  1. For i = 1 To 3
  2. Cells(1, 1).AutoFilter 3, i
  3. Cells(1, 1).CurrentRegion.Copy '這樣出錯, 只可將部份內容另存工作表
  4. Worksheets.Add after:=Worksheets(Worksheets.Count)[attach]28806[/attach]
  5. Worksheets(Worksheets.Count).Name = "SHEET" & i
  6. ActiveSheet.Paste
  7. Application.CutCopyMode = False
  8. Sheets(1).Select
  9. ActiveSheet.ShowAllData
  10. Next i
  11. ActiveSheet.AutoFilterMode = False
  12. End Sub


  15. Sub myName() '用每工仍表的C6儲存格為工作表命名
  16. For i = 2 To Worksheets.Count
  17. Worksheets(i).Name = Worksheets(i).Cells(2, 1)
  18. Next
  19. End Sub
複製代碼
作者: ikboy    時間: 2018-6-9 10:20

  1. Sub zz()
  2. Application.ScreenUpdating = 0
  3. Dim rng As Range, d As Object, ws As Worksheet
  4. Set ws = ActiveSheet
  5. ws.AutoFilterMode = False
  6. c = [a3].CurrentRegion.Columns.Count
  7. Set d = CreateObject("scripting.dictionary")
  8. Set rng = Range([a5], Cells(Cells(Rows.Count, 1).End(3).Row, c))
  9. a = rng.Columns(3)
  10. For i = 2 To UBound(a)
  11.     d(a(i, 1)) = ""
  12. Next
  13. k = d.keys
  14. For i = 0 To UBound(k)
  15.     ws.Copy after:=Sheets(Sheets.Count)
  16.     ActiveSheet.AutoFilterMode = False
  17.     [a3].CurrentRegion.Clear
  18.     With ws
  19.         rng.AutoFilter Field:=3, Criteria1:=k(i)
  20.         .[a3].CurrentRegion.Copy [a3]
  21.         
  22.     End With
  23.     ActiveSheet.Name = [c6].Value
  24. Next
  25. Application.ScreenUpdating = 1
  26. End Sub
複製代碼
作者: missbb    時間: 2018-6-11 17:20

回復 2# ikboy
感謝, 我要洧化及學習.:D
作者: missbb    時間: 2018-6-11 19:28

本帖最後由 missbb 於 2018-6-11 19:32 編輯

大大IKBOY你好, 我將你指導的放入較多資料的EXCEL, 自己加入檢視資料的改動.  但執行時出現1004的錯誤, 請幫忙看那裡出錯?

我是要在SHEET DATA之後, 保留工作表1及工作表二,即分部門新增的工作表, 是要在工作表二之後新增.

[attach]28814[/attach]
  1. Sub sortingsavesheet2()
  2. 'use this , sorting dept then save individualsheet with deptname

  4. Application.ScreenUpdating = 0
  5. Dim rng As Range, d As Object, ws As Worksheet
  6. Set ws = ActiveSheet
  7. ws.AutoFilterMode = False
  8. c = [a3].CurrentRegion.Columns.Count
  9. Set d = CreateObject("scripting.dictionary")
  10. Set rng = Range([a5], Cells(Cells(Rows.Count, 1).End(3).Row, c))
  11. a = rng.Columns(3)
  12. For i = 2 To UBound(a)
  13.     d(a(i, 1)) = ""
  14. Next
  15. k = d.keys
  16. For i = 0 To UBound(k)
  17.     ws.Copy after:=Sheets(Sheets.Count)
  18.     ActiveSheet.AutoFilterMode = False
  19.     [a3].CurrentRegion.Clear
  20.     With ws
  21.         rng.AutoFilter Field:=3, Criteria1:=k(i)
  22.         .[a3].CurrentRegion.Copy [a3]
  23.         
  24.     Range("F6").Select
  25.     With ActiveWindow
  26.         .SplitColumn = 5
  27.         .SplitRow = 5
  28.     End With
  29.     ActiveWindow.FreezePanes = True
  30.       
  31.     End With
  32.       
  33.     ActiveSheet.Name = [c6].Value
  34. Next
  35. Application.ScreenUpdating = 1

  37. With Sheets("data").Activate
  38.     If ActiveSheet.FilterMode Then
  39.       ActiveSheet.ShowAllData
  40.     End If
  41. [color=Red]'自行加入凍結窗及最後返回DATA的F6[/color]  
  42. Range("F6").Select
  43. With ActiveWindow
  44.         .SplitColumn = 5
  45.         .SplitRow = 5
  46.     End With
  47.     ActiveWindow.FreezePanes = True
  48.    
  49. End With
  50. End Sub
複製代碼
回復 2# ikboy
作者: ikboy    時間: 2018-6-12 10:08

檔案無法打開
作者: missbb    時間: 2018-6-12 20:57

[attach]28827[/attach]
補回附件:P
回復 5# ikboy
作者: ikboy    時間: 2018-6-14 14:18

代碼不要放入sheets內。
作者: missbb    時間: 2018-6-15 08:52

感謝協力



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