kirimpertanyaan

 

Belajar dan konsultasi masalah Excel      

Macro & VBA, Hits: 52, Comments: 0, Bookmarked: 0, Followers: 4

Halo Pak Acan dan Pak Ardo. Saya newbie dalam belajar excel VBA dan telah belajar banyak dari buku Kitab VBA Excel Level 1. Alhamdulillah saya sedikit-sedikit mengerti.

Saat ini saya sedang mengerjakan tugas untuk tesis saya. Namun saya mengalami kebingungan dalam running code berikut.

Saya ingin mengimpor beberapa csv files dari folder yg saya pilih ke dalam satu worksheets dan berhasil menggunakan kode berikut:

Sub ImportMultipleCSV()

    Dim xSht  As Worksheet

    Dim xWb As Workbook

    Dim xStrPath As String

    Dim xFileDialog As FileDialog

    Dim xFile As String

    On Error GoTo ErrHandler

    

    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

    xFileDialog.AllowMultiSelect = False

    xFileDialog.Title = "Select a folder"

    If xFileDialog.Show = -1 Then

        xStrPath = xFileDialog.SelectedItems(1)

    End If

    If xStrPath = "" Then Exit Sub

    

    Set xSht = Worksheets("Admin")

    If MsgBox("Clear the existing sheet before importing?", vbYesNo) = vbYes Then xSht.UsedRange.Clear

    Application.ScreenUpdating = False

    xFile = Dir(xStrPath & "\" & "*.csv")

    

    Do While xFile <> ""

        Set xWb = Workbooks.Open(xStrPath & "\" & xFile)

 ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)

        xWb.Close False

        xFile = Dir

    Loop

    Application.ScreenUpdating = True

    Exit Sub

ErrHandler:

    MsgBox "no files csv"

End Sub

Namun kode tersebut tidak merapikan file CSV saya, hanya memindahkan saja menjadi satu dalam satu worksheets. Saya kemudian mencoba salah satu file dalam folder tersebut untuk dirapikan dengan menggunakan macro recording dan berikut kodenya:

Sub Macro1()

'

' Macro1 Macro

'

'

    ActiveWorkbook.Queries.Add Name:="PROT0720 (3)", Formula:= _

        "let" & Chr(13) & "" & Chr(10) & "    Source = Csv.Document(File.Contents(""D:\TUM\Study Project\Study Project TUM\automatic sampler raw data\PROT0720.CSV""),[Delimiter="";"", Columns=12, Encoding=1252, QuoteStyle=QuoteStyle.None])," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Source,{{""Column1"", type text}, {""Column2"", type text}, {""Column3"", type text}, {""Column4"", type text}, " & _

        "{""Column5"", type text}, {""Column6"", type text}, {""Column7"", type text}, {""Column8"", type text}, {""Column9"", type text}, {""Column10"", type text}, {""Column11"", type text}, {""Column12"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""

    ActiveWorkbook.Worksheets.Add

    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _

        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""PROT0720 (3)"";Extended Properties=""""" _

        , Destination:=Range("$A$1")).QueryTable

        .CommandType = xlCmdSql

        .CommandText = Array("SELECT * FROM [PROT0720 (3)]")

        .RowNumbers = False

        .FillAdjacentFormulas = False

        .PreserveFormatting = True

        .RefreshOnFileOpen = False

        .BackgroundQuery = True

        .RefreshStyle = xlInsertDeleteCells

        .SavePassword = False

        .SaveData = True

        .AdjustColumnWidth = True

        .RefreshPeriod = 0

        .PreserveColumnInfo = True

        .ListObject.DisplayName = "PROT0720__3"

        .Refresh BackgroundQuery:=False

    End With

End Sub

Ketika saya mencoba menggabungkan kedua kode tersebut, saya mendapati error. Sudah dua hari saya mencoba namun hasilnya nihil. Mohon pencerahannya apabila Pak Acan dan Pak Ardo mengerti mengenai hal ini. Terima Kasih 😊

 


kasihdita
Friday, September 29, 2017
0% of 0 votes

Kitab VBA Excel Level Satu

Buat pemula yang serius pengen belajar MACRO VBA Excel, silahkan baca buku berikut:

Kitab VBA Excel Level Satu edisi 2 sEDISI 2 : Rp. 60.000

BELI VERSI CETAK KLIK DI SINI

BELI VERSI DIGITAL KLIK DI SINI

LIHAT PREVIEW KLIK DI SINI

 

Partners

logo baru local1news

Newsletter

Daftarkan email anda untuk mendapatkan update dari Klinik Excel