返回列表 上一主題 發帖

[發問] 請問如何依篩選欄的類別,自動建立分頁建立後並分類資料?

[發問] 請問如何依篩選欄的類別,自動建立分頁建立後並分類資料?

目前須手動建立篩選欄位內的分頁才能自動導入資料
  1. Sub Ex()
  2.     Dim Sh As Worksheet
  3.     With Sheets("彙總明細")
  4.         For Each Sh In Sheets          'Sheets : 工作表物件的集合物件
  5.             If Sh.Name <> .Name Then   '工作表的名稱<>"彙總明細"
  6.                 .Range("A1").AutoFilter Field:=2, Criteria1:=Sh.Name
  7.                 '"彙總明細" 自動篩選  篩選基準欄位:=第2欄 , 篩選準則:="工作表名稱"
  8.                 .UsedRange.Columns("a:d").Copy Sh.[a1] '"彙總明細" 自動篩選後的資料, 複製
  9.             End If
  10.         Next
  11.         .Range("A1").AutoFilter   '取消 "彙總明細"自動篩選模式
  12.     End With
  13. End Sub
複製代碼

Sub test()
Dim Sht As Worksheet, xD, xR As Range
Set xD = CreateObject("Scripting.Dictionary")
xD("") = 1
With Sheets("彙總明細").UsedRange
  For Each xR In .Columns(2).Offset(1, 0).Cells
    If xD(xR.Value) = "" Then
     On Error Resume Next
     Set Sht = Sheets(xR.Value)
     On Error GoTo 0
     If Sht Is Nothing Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = xR.Value
     .AutoFilter Field:=2, Criteria1:=xR.Value
     .Columns("a:d").Copy Sheets(xR.Value).[a1]
     xD(xR.Value) = 1: Set Sht = Nothing
    End If
  Next
  Application.Goto .Item(1)
End With
Sheets("彙總明細").AutoFilterMode = False
End Sub
 
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 2# 准提部林

太感謝你了!!!!!!!!!!!!!!!!!!

TOP

進階篩選+自動篩選
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Sh As Worksheet, Ar As Variant, i As Integer, M As Variant
  4.     With ActiveWorkbook.Sheets("彙總明細")
  5.         .Range("b:b").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
  6.         With .Cells(1, .Columns.Count).EntireColumn
  7.             Ar = .SpecialCells(xlCellTypeConstants)
  8.             Ar = Application.WorksheetFunction.Transpose(Ar)
  9.             .Cells = ""
  10.         End With
  11.         On Error GoTo Sheet_Add   '處裡工作表不存在的錯誤
  12.         For i = 2 To UBound(Ar)
  13.             .Range("A1").AutoFilter Field:=2, Criteria1:=Ar(i)
  14.             .UsedRange.Columns("a:d").Copy ActiveWorkbook.Sheets(Ar(i)).[a1] '"彙總明細" 自動篩選後的資料, 複製
  15.         Next
  16.         .Range("A1").AutoFilter   '取消 "彙總明細"自動篩選模式
  17.         .Activate
  18.         On Error GoTo 0             '程式有錯誤不處裡
  19.         '刪除工作表不存"彙總明細"篩選欄的類別
  20.         Application.DisplayAlerts = False
  21.         For Each Sh In ActiveWorkbook.Sheets
  22.             If Sh.Name <> .Name Then If IsError(Application.Match(Sh.Name, Ar, 0)) Then Sh.Delete
  23.         Next
  24.         Application.DisplayAlerts = True
  25.     End With
  26.     Exit Sub
  27. '******************************
  28. Sheet_Add:
  29.      ActiveWorkbook.Sheets.Add.Name = Ar(i)
  30.     Resume
  31. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 4# GBKEE

感謝版大~努力吸收!!!

TOP

        靜思自在 : 【做人的開始】每一天都是故人的開始,每一個時刻都是自己的警惕。
返回列表 上一主題