VBA 另存CSV檔(UTF-8),將篩選內容轉存至指定儲存格

 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 '選取過濾內容

               

                Selection.Copy Sheets("13(異常件保單明細)").Range("a12") '復制過濾內容到目的地的儲存格往下貼符合的資料出來

            

            pw = saveFile_13(gn, 13)

                       

            fsT.WriteText gn & "," & pw & Chr(13)      'CHR(13)為斷行符號

        Next

        

        fsT.SaveToFile tFilePath, 2      

        writeOut = 1

      WriteUTF8 = True

    End With

            

    rng.AutoFilter          '解除自動篩選狀態

    

    td = DateDiff("s", Now, b1)

    MsgBox "轉檔完成~~~" & td & "秒"

    

End Sub