返回列表 上一主題 發帖

[發問] 1張主工作表篩選後新增工作表及命名

[發問] 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) 1工作表篩選後另存工作表及以篩選結果命名.zip (28.96 KB)
  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


  13. Sub myName() '用每工仍表的C6儲存格為工作表命名
  14. For i = 2 To Worksheets.Count
  15. Worksheets(i).Name = Worksheets(i).Cells(2, 1)
  16. Next
  17. End Sub
複製代碼

  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
複製代碼

TOP

回復 2# ikboy
感謝, 我要洧化及學習.:D

TOP

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

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

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

new.zip (37.07 KB)
  1. Sub sortingsavesheet2()
  2. 'use this , sorting dept then save individualsheet with deptname

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

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

TOP

檔案無法打開

TOP

複本 new.zip (30.05 KB)
補回附件:P
回復 5# ikboy

TOP

代碼不要放入sheets內。

複本 new.zip (35.12 KB)

TOP

感謝協力

TOP

        靜思自在 : 真正的愛心,是照顧好自己的這顆心。
返回列表 上一主題