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 😊
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 😊