hank

  Function saveFile_13(name, month) Dim RS As New ADODB.Recordset     sPath = ThisWorkbook.Path     Sheets("13").Select          Application.ScreenUpdating = False          X="A1234567890"         If Len(Trim(X)) > 0 Then                            Application.DisplayAlerts = False                 pw = Left(X, 1) & Right(X, 5)                                  '另存成PDF                'Sheets("13").ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath & "\" & Replace(name, "*", "") & "_" & month & "個月.pdf"                 '另存xlsx                  Worksheets("13").Copy                  ActiveWorkbook.SaveAs Filename:=sPath & "\" & Replace(name, "*", "") & "_" & month & "個月.xlsx", FileFormat:=xlOpenXMLWorkbook, Password:=pw                 ActiveWorkbook.Close              Application.DisplayAler

 Sub doExport_13() Dim rng As Range        '自動篩選結果範圍  b1 = Now           With Sheets("13_整理")               .Activate         'Worksheets("25").Activate         Set rng = .UsedRange    '所有資料範圍                         Dim fsT As Object         Dim tFilePath As String         tFilePath = ThisWorkbook.Path & "\" & "13_pw.csv"         'Create Stream object         Set fsT = CreateObject("ADODB.Stream")         fsT.Type = 2         fsT.Charset = "utf-8"         fsT.Open         fsT.WriteText "A1,A2,A3" + Chr(13)     '標頭         rng.AutoFilter    '設定自動篩選         TR = Worksheets("執行").UsedRange.Rows.Count         For I = 2 To TR                          .Activate             gn = Worksheets("執行").Cells(I, 17)    '取要篩選的值出來             rng.AutoFilter Field:=2, Criteria1:=gn  '選擇過瀘位置,設定過濾條件                              .Range("a1").CurrentRegion.Select '

  Sub doFilterGroup_13_整理()     Dim d, rng As Range, cel As Range     Set d = CreateObject("scripting.dictionary")   '建立 Dictionary物件 '先將目的地的儲存格清成空白     With Worksheets("執行")         Set rng = .[q:q]         rng.Value = ""     End With     With Worksheets("13_整理")         Set rng = .[b:b]      '設定B欄為要篩選資料的範圍         .Activate       End With      '將資料塞入Dictionary的物件中     For Each cel In rng        If cel.Value <> "" Then d(cel.Value) = ""       Next      '將篩選後的不重複值存入Sheets("執行").[Q1]中     Sheets("執行").[Q1].Resize(d.Count) = Application.Transpose(d.keys)          End Sub