Note: The other languages of the website are Google-translated. Back to English
English English

Bagaimana cara mengimpor beberapa file teks dari folder ke dalam satu lembar kerja?

Misalnya, di sini Anda memiliki folder dengan beberapa file teks, yang ingin Anda lakukan adalah mengimpor file teks ini ke dalam satu lembar kerja seperti tampilan gambar di bawah ini. Alih-alih menyalin file teks satu per satu, adakah trik untuk mengimpor file teks dengan cepat dari satu folder ke dalam satu lembar?

Impor beberapa file teks dari satu folder ke dalam satu lembar dengan VBA

Impor file teks ke sel aktif dengan Kutools for Excel ide bagus3


Berikut adalah kode VBA yang dapat membantu Anda mengimpor semua file teks dari satu folder tertentu ke dalam lembar baru.

1. Aktifkan buku kerja yang ingin Anda impor file teksnya, dan tekan Alt + F11 kunci untuk mengaktifkan Microsoft Visual Basic untuk Aplikasi jendela.

2. klik Menyisipkan > Modul, salin dan tempel kode VBA di bawah ini ke Modul jendela.

VBA: Impor beberapa file teks dari satu folder ke satu lembar

Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

3. tekan F5 untuk menampilkan dialog, dan pilih folder yang berisi file teks yang ingin Anda impor. Lihat tangkapan layar:
doc mengimpor file teks dari folder 1

4. klik OK. Kemudian file teks telah diimpor ke buku kerja aktif sebagai lembar baru secara terpisah.
doc mengimpor file teks dari folder 2


Jika Anda ingin mengimpor satu file teks ke sel atau rentang tertentu, Anda dapat menerapkan Kutools untuk Excel'S Sisipkan File di Cursor utilitas

Kutools untuk Excel, dengan lebih dari 300 fungsi praktis, membuat pekerjaan Anda lebih mudah. 

Setelah pemasangan gratis Kutools for Excel, lakukan seperti di bawah ini:

1. Pilih sel yang ingin Anda impor file teksnya, dan klik Kutools Plus > Ekspor Impor > Sisipkan File di Cursor. Lihat tangkapan layar:
doc mengimpor file teks dari folder 3

2. Kemudian sebuah dialog muncul, klik Browse untuk menampilkan Pilih sebuah file untuk disisipkan pada dialog posisi kursor sel, pilih berikutnya File Teks dari daftar turun bawah, lalu pilih file teks yang ingin Anda impor. Lihat tangkapan layar:
doc mengimpor file teks dari folder 4

3. klik Open > Ok, dan file teks tentukan telah dimasukkan pada posisi kursor, lihat tangkapan layar:
doc mengimpor file teks dari folder 5


Alat Produktivitas Kantor Terbaik

Kutools for Excel Memecahkan Sebagian Besar Masalah Anda, dan Meningkatkan Produktivitas Anda hingga 80%

  • Reuse: Masukkan dengan cepat rumus, bagan yang kompleks dan apa pun yang pernah Anda gunakan sebelumnya; Enkripsi Sel dengan kata sandi; Buat Milis dan mengirim email ...
  • Bilah Formula Super (dengan mudah mengedit beberapa baris teks dan rumus); Membaca Tata Letak (membaca dan mengedit sel dalam jumlah besar dengan mudah); Tempel ke Rentang yang Difilter...
  • Gabungkan Sel / Baris / Kolom tanpa kehilangan Data; Pisahkan Konten Sel; Gabungkan Baris / Kolom Duplikat... Mencegah Sel Duplikat; Bandingkan Rentang...
  • Pilih Duplikat atau Unik Baris; Pilih Baris Kosong (semua sel kosong); Temukan Super dan Temukan Fuzzy di Banyak Buku Kerja; Pilih Acak ...
  • Salinan Tepat Beberapa Sel tanpa mengubah referensi rumus; Buat Referensi Otomatis ke Beberapa Lembar; Sisipkan Poin, Kotak Centang, dan lainnya ...
  • Ekstrak Teks, Tambahkan Teks, Hapus berdasarkan Posisi, Hapus Space; Membuat dan Mencetak Subtotal Paging; Konversi Konten Antar Sel dan Komentar...
  • Filter Super (simpan dan terapkan skema filter ke sheet lain); Penyortiran Lanjutan menurut bulan / minggu / hari, frekuensi dan lainnya; Filter Khusus dengan huruf tebal, miring ...
  • Gabungkan Workbooks dan WorkSheets; Gabungkan Tabel berdasarkan kolom kunci; Pisahkan Data menjadi Beberapa Lembar; Konversi Batch xls, xlsx dan PDF...
  • Lebih dari 300 fitur canggih. Mendukung Office / Excel 2007-2019 dan 365. Mendukung semua bahasa. Penerapan yang mudah di perusahaan atau organisasi Anda. Fitur lengkap uji coba gratis 30 hari. Jaminan uang kembali 60 hari.
tab kte 201905

Tab Office Membawa antarmuka Tab ke Office, dan Membuat Pekerjaan Anda Jauh Lebih Mudah

  • Aktifkan pengeditan dan pembacaan tab di Word, Excel, PowerPoint, Publisher, Access, Visio, dan Project.
  • Buka dan buat banyak dokumen di tab baru di jendela yang sama, bukan di jendela baru.
  • Tingkatkan produktivitas Anda hingga 50%, dan kurangi ratusan klik mouse untuk Anda setiap hari!
officetab bawah
Urutkan komentar berdasarkan
komentar (41)
Belum ada peringkat. Jadilah yang pertama memberi peringkat!
Komentar ini diminimalkan oleh moderator di situs
Sub Tes()
'Perbarui olehExtendoffice6 / 7 / 2016
Redupkan xWb Sebagai Buku Kerja
Redupkan xToBook Sebagai Buku Kerja
Redupkan xStrPath Sebagai String
Redupkan xFileDialog Sebagai FileDialog
Redupkan xFile Sebagai String
Redupkan xFiles Sebagai Koleksi Baru
Redup Aku Selamanya
Setel xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Salah
xFileDialog.Title = "Pilih folder [Kutools for Excel]"
Jika xFileDialog.Show = -1 Maka
xStrPath = xFileDialog.SelectedItems(1)
End If
Jika xStrPath = "" Kemudian Keluar Sub
Jika Benar(xStrPath, 1) <> "\" Kemudian xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Jika xFile = "" Maka
MsgBox "Tidak ada file yang ditemukan", vbInformation, "Kutools for Excel"
Keluar dari Sub
End If
Lakukan Sementara xFile <> ""
xFiles.Tambahkan xFile, xFile
xFile = Dir()
Lingkaran
Setel xToBook = Buku Kerja Ini
Jika xFiles.Count > 0 Kemudian
Untuk I = 1 Untuk xFiles.Count
Setel xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Salin setelah:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
LembarAktif.Nama = xWb.Nama
Pada Kesalahan GoTo 0
xWb.Tutup Salah
Next
End If
End Sub

kode ini membantu tetapi saya ingin

tab, titik koma, spasi benar bagaimana melakukannya, tolong bantu saya
Komentar ini diminimalkan oleh moderator di situs
Apakah Anda ingin menyimpan ruang (pembatas) setelah mengonversi file teks menjadi lembar?
Komentar ini diminimalkan oleh moderator di situs
itu masalah saya juga, kode ini benar. tetapi setelah mengonversi file teks ke excel, itu tidak menyimpan pembatas.
Komentar ini diminimalkan oleh moderator di situs
Bisakah Anda mengunggah file teks dan hasil yang Anda inginkan untuk saya?
Komentar ini diminimalkan oleh moderator di situs
Saya memiliki masalah yang sama. Semua file txt berada di lembar terpisah dan kode mengabaikan spasi di antara dua kolom
Komentar ini diminimalkan oleh moderator di situs
Halo, Des dan PB Rama Murty, kode di bawah ini dapat membagi data menjadi kolom berdasarkan spasi atau tab saat mengimpor file teks ke lembar. Anda bisa mencoba.

Sub ImportTextToExcel()
'Perbarui olehExtendoffice20180911
Redupkan xWb Sebagai Buku Kerja
Redupkan xToBook Sebagai Buku Kerja
Redupkan xStrPath Sebagai String
Redupkan xFileDialog Sebagai FileDialog
Redupkan xFile Sebagai String
Redupkan xFiles Sebagai Koleksi Baru
Redup Aku Selamanya
Redupkan xIntRow Selamanya
Redupkan xFNum, xFArr Selamanya
Redupkan xStrValue Sebagai String
Redupkan xRg Sebagai Rentang
redup xArr
Setel xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Salah
xFileDialog.Title = "Pilih folder [Kutools for Excel]"
Jika xFileDialog.Show = -1 Maka
xStrPath = xFileDialog.SelectedItems(1)
End If
Jika xStrPath = "" Kemudian Keluar Sub
Jika Benar(xStrPath, 1) <> "\" Kemudian xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Jika xFile = "" Maka
MsgBox "Tidak ada file yang ditemukan", vbInformation, "Kutools for Excel"
Keluar dari Sub
End If
Lakukan Sementara xFile <> ""
xFiles.Tambahkan xFile, xFile
xFile = Dir()
Lingkaran
Setel xToBook = Buku Kerja Ini
On Error Resume Next
Application.ScreenUpdating = Salah
Jika xFiles.Count > 0 Kemudian

Untuk I = 1 Untuk xFiles.Count
Setel xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Salin setelah:=xToBook.Sheets(xToBook.Sheets.Count)

LembarAktif.Nama = xWb.Nama

xWb.Tutup Salah
xIntRow = ActiveCell.CurrentRegion.Rows.Count
Untuk xFNum = 1 Ke xIntRow
Setel xRg = ActiveSheet.Range("A" & xFNum)
xArr = Pisahkan(xRg.Teks, " ")
Jika UBound(xArr) > 0 Maka
Untuk xFArr = 0 Ke UBound(xArr)
Jika xArr(xFArr) <> "" Maka
xRg.Nilai = xArr(xFArr)
Tetapkan xRg = xRg.Offset(ColumnOffset:=1)
End If
Next
End If
Next
Next
End If
Application.ScreenUpdating = Benar
End Sub
Komentar ini diminimalkan oleh moderator di situs
Perubahan apa yang diperlukan jika ingin membagi data menjadi kolom berdasarkan koma?
Komentar ini diminimalkan oleh moderator di situs
Perubahan apa yang perlu dilakukan jika saya perlu memasukkan data ke dalam kolom berdasarkan koma?
Komentar ini diminimalkan oleh moderator di situs
bagaimana jika file Txt saya berisi delimited menggunakan koma?
Komentar ini diminimalkan oleh moderator di situs
Anda dapat menggunakan fungsi Find and Replace untuk mengganti koma dengan spasi terlebih dahulu, dan menerapkan salah satu metode di atas untuk mengubahnya menjadi file Excel.
Komentar ini diminimalkan oleh moderator di situs
Apakah tidak ada cara untuk mengubah ini dalam kode? Saya harus melakukan ini dengan 130 file
Komentar ini diminimalkan oleh moderator di situs
Pertanyaan yang sama
Komentar ini diminimalkan oleh moderator di situs
Bagi yang masih membutuhkan bantuan, ganti xArr = Split(xRg.Text, " ") dengan xArr = Split(xRg.Text, ",").
Komentar ini diminimalkan oleh moderator di situs
Ketika saya menjalankan modul seperti yang diberikan, ia menambahkan setiap file .txt sebagai lembar baru, bukan sebagai baris baru ke lembar yang ada. Apakah ada cara untuk mencapainya sebagai output alih-alih lembar baru untuk setiap file .txt?
Komentar ini diminimalkan oleh moderator di situs
Apakah yang Anda maksud: menggabungkan semua file teks menjadi satu lembar?
Komentar ini diminimalkan oleh moderator di situs
Ya ini juga yang saya inginkan.
Komentar ini diminimalkan oleh moderator di situs
Hai, Davinder, Anda dapat mencoba kode vba di bawah ini.
Sub ImportCSVsWithReference()
'UpdatebyKutoolsforExcel20151214
    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 [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Set xSht = ThisWorkbook.ActiveSheet
    If MsgBox("Clear the existing sheet before importing?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
    Application.ScreenUpdating = False
    xFile = Dir(xStrPath & "\" & "*.txt")
    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 txt files", , "Kutools for Excel"
End Sub
Komentar ini diminimalkan oleh moderator di situs
Kode ini sangat membantu, ini adalah satu-satunya kode yang saya temukan yang mendapatkan file txt dalam jumlah besar, perbaikan yang saya perlukan juga yang diinginkan Joyce dan Davinder.
Ini untuk mengekstrak file .txt dan menempelkannya di bawah satu sama lain di kolom tertentu, katakanlah kolom 'N'.

Juga, perlu diketahui apakah mungkin untuk menambahkan "kondisi if" untuk file .txt yang diimpor menjadi sebagai berikut.
jika file .txt dimulai dengan huruf 'A' kemudian ditempelkan pada 'sheet 1' dimulai dengan sel 'N2'
dan jika file .txt dimulai dengan huruf 'B' lalu tempel di 'Sheet 2' dimulai dengan sel 'N2'
lain MsgBox menjadi "Tujuan file .txt tidak dikenal".

Terima kasih sebelumnya
Komentar ini diminimalkan oleh moderator di situs
Saya memiliki kode ini berfungsi untuk saya tetapi tetap saja, saya perlu mengubah beberapa di dalamnya.

*Saya ingin menempelkannya pada lembar yang sama tanpa membuka lembar baru lalu menyalinnya karena membutuhkan waktu lebih lama.

*perlu menyisipkan conditional jika untuk file txt yang diimpor akan ditempel pada lembar 1 jika dimulai dengan huruf A dan diimpor ke Lembar 2 jika dimulai dengan huruf B


Sub tescopy3()
Redupkan xWb Sebagai Buku Kerja
Redupkan xToBook Sebagai Buku Kerja
Redupkan xStrPath Sebagai String
Redupkan xFileDialog Sebagai FileDialog
Redupkan xFile Sebagai String
Redupkan xFiles Sebagai Koleksi Baru
Redupkan Aku Selamanya
Redup Baris Terakhir Selamanya
Dim Rng Sebagai Rentang
Setel xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Salah
xFileDialog.Title = "Pilih folder [Kutools for Excel]"
Jika xFileDialog.Show = -1 Maka
xStrPath = xFileDialog.SelectedItems(1)
End If
Jika xStrPath = "" Kemudian Keluar Sub
Jika Benar(xStrPath, 1) <> "\" Kemudian xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Jika xFile = "" Maka
MsgBox "Tidak ada file yang ditemukan", vbInformation, "Kutools for Excel"
Keluar dari Sub
End If
Lakukan Sementara xFile <> ""
xFiles.Tambahkan xFile, xFile
xFile = Dir()
Lingkaran
Rentang("N2").Pilih
Setel xToBook = Buku Kerja Ini
Jika xFiles.Count > 0 Kemudian
Untuk i = 1 Ke xFiles.Count
Setel xWb = Buku Kerja.Buka(xStrPath & xFiles.Item(i))
xWb.Aktifkan
'Memilih dan menyalin data txt
Rentang(Pilihan, Pilihan.End(xlDown)).Pilih
Seleksi.Salin
xToBook.Aktifkan
ActiveSheet.Paste
Pilihan.End(xlDown).Offset(1).Pilih
On Error Resume Next
Pada Kesalahan GoTo 0
xWb.Tutup Salah
Next
End If
End Sub
Komentar ini diminimalkan oleh moderator di situs
Maaf, tanganku terikat
Komentar ini diminimalkan oleh moderator di situs
Hai, kode saya berjalan tetapi hanya mengimpor file pertama. Dikatakan ada kesalahan metode untuk menyalin. Debugger menyoroti baris kode berikut. Ada ide?


xWb.Worksheets(1).Salin setelah:=xToBook.Sheets(xToBook.Sheets.Count)
Komentar ini diminimalkan oleh moderator di situs
Saya memiliki masalah yang sama, adakah solusi yang ditemukan?
Komentar ini diminimalkan oleh moderator di situs
Hei katie,
Saya tahu bahwa komentar Anda cukup lama, tetapi saya menghadapi masalah yang sama dan memperbaikinya dengan cara ini: Modul harus dimasukkan ke dalam subfolder dari proyek .xlsx yang aktif. Saya membuat kesalahan dengan menyalin kode ke dalam subfolder PERSONAL.XLSB saya di mana saya biasanya menyimpan makro saya dan itu juga dengan makro saya yang lain, tetapi tidak dengan yang ini.
Komentar ini diminimalkan oleh moderator di situs
Bagaimana Anda menghapus lembar dalam kode vba jika Anda tidak ingin duplikat saat menjalankan kembali modul?
Komentar ini diminimalkan oleh moderator di situs
Maaf, Harsh, berhati-hatilah agar tidak mengimpor berulang kali.
Komentar ini diminimalkan oleh moderator di situs
hai saya ingin mencegah menghapus nol sebelumnya di excel.

saya sudah mencoba kode di bawah ini tetapi tidak berhasil


Sub Tes()
Redupkan xWb Sebagai Buku Kerja
Redupkan xToBook Sebagai Buku Kerja
Redupkan xStrPath Sebagai String
Redupkan xFileDialog Sebagai FileDialog
Redupkan xFile Sebagai String
Redupkan xFiles Sebagai Koleksi Baru
Redup Aku Selamanya
Dim j Selamanya
Setel xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Salah
xFileDialog.Title = "Pilih folder"
Jika xFileDialog.Show = -1 Maka
xStrPath = xFileDialog.SelectedItems(1)
End If
Jika xStrPath = "" Kemudian Keluar Sub
Jika Benar(xStrPath, 1) <> "\" Kemudian xStrPath = xStrPath & "\"
xFile = Dir(xStrPath & "*.txt")
Jika xFile = "" Maka
MsgBox "Tidak ada file yang ditemukan", vbInformation, "Kutools for Excel"
Keluar dari Sub
End If
Lakukan Sementara xFile <> ""
xFiles.Tambahkan xFile, xFile
xFile = Dir()
Lingkaran
Setel xToBook = Buku Kerja Ini
Jika xFiles.Count > 0 Kemudian
Untuk I = 1 Untuk xFiles.Count
Setel xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
ActiveSheet.Cells.NumberFormat = "@" 'Ini untuk membuat excel dalam format teks sebelum menempelkan data file teks
xWb.Worksheets(1).Salin Setelah:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
LembarAktif.Nama = xWb.Nama
Pada Kesalahan GoTo 0
xWb.Tutup Salah
Next
End If
End Sub
Komentar ini diminimalkan oleh moderator di situs
Pooja, Anda dapat mencoba fungsi Hapus Nol Terkemuka dari Kutools for Excel untuk menghapus semua nol di depan dari pilihan setelah mengimpor.
Komentar ini diminimalkan oleh moderator di situs
tapi saya tidak ingin menghapus. Saya ingin mencegah menghapus nol sebelumnya.
Komentar ini diminimalkan oleh moderator di situs
Jika Anda ingin mempertahankan angka nol di depan, Anda dapat memformatnya sebagai format teks menurut Format Sel.
Komentar ini diminimalkan oleh moderator di situs
Halo, bagaimana Anda memodifikasi kode ini untuk menyisipkan file *.txt dengan urutan: 1,2,3,4,5,6,7,8,9,10,11, dll. Saat ini kode menyisipkan file sebagai berikut:1,10,11,12,13,14,15,16,17,18,19,2,20,21, XNUMX, dll. Terima kasih!
Komentar ini diminimalkan oleh moderator di situs
apakah ada kemungkinan untuk mengambil nama sheet hanya bagian tertentu dari nama file txt?

sesuai kode di atas, seluruh nama lembar telah diambil.
Komentar ini diminimalkan oleh moderator di situs
terima kasih banyak melakukan pekerjaan di office 2007 excel
Komentar ini diminimalkan oleh moderator di situs
Hai, kode saya berjalan tetapi hanya mengimpor file pertama. Dikatakan ada kesalahan metode untuk menyalin. Debugger menyoroti baris kode berikut. Ada ide?


xWb.Worksheets(1).Salin setelah:=xToBook.Sheets(xToBook.Sheets.Count)
Komentar ini diminimalkan oleh moderator di situs
Hei Martino,
Saya memiliki Masalah yang sama dan menyelesaikannya dengan mengubah baris ini:
Setel xToBook = Buku Kerja Ini
untuk
Setel xToBook = ActiveWorkbook
Mungkin ini membantu.
Komentar ini diminimalkan oleh moderator di situs
0

saya butuh bantuan Anda saya tidak tahu vba excel saya ingin mengimpor beberapa file teks seperti 13000. nama file teks sama dengan sel misalnya (c1=112 jadi nama file teks juga 112) berarti file teks 112 adalah impor c112.
Komentar ini diminimalkan oleh moderator di situs
saya butuh bantuan Anda saya tidak tahu vba excel saya ingin mengimpor beberapa file teks seperti 13000. nama file teks sama dengan sel misalnya (c1=112 jadi nama file teks juga 112) berarti file teks 112 adalah impor c112.
Komentar ini diminimalkan oleh moderator di situs
Kode berfungsi tetapi mengimpor setiap file teks ke tab baru di buku kerja. Adakah ide di mana dalam kode ini dapat diubah untuk mengimpor file teks baru pada lembar kerja yang sama di bawah data dari file teks terakhir?
Komentar ini diminimalkan oleh moderator di situs
Dalam kode di bawah ini jika saya ingin menentukan folder daripada memilih jalur setiap kali mengimpor file teks, modifikasi apa yang harus dilakukan

KODE VBA:

Sub ImporCSVsDenganReferensi()
'Perbarui olehKutoolsforExcel20151214
Redupkan xSht Sebagai Lembar Kerja
Redupkan xWb Sebagai Buku Kerja
Redupkan xStrPath Sebagai String
Redupkan xFileDialog Sebagai FileDialog
Redupkan xFile Sebagai String
Pada Kesalahan GoTo ErrHandler
Setel xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = Salah
xFileDialog.Title = "Pilih folder [Kutools for Excel]"
Jika xFileDialog.Show = -1 Maka
xStrPath = xFileDialog.SelectedItems(1)
End If
Jika xStrPath = "" Kemudian Keluar Sub
Setel xSht = ThisWorkbook.ActiveSheet
If MsgBox("Hapus lembar yang ada sebelum mengimpor?", vbYesNo, "Kutools for Excel") = vbYes Then xSht.UsedRange.Clear
Application.ScreenUpdating = Salah
xFile = Dir(xStrPath & "\" & "*.txt")
Lakukan Sementara xFile <> ""
Setel xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Tutup Salah
xFile = Dir
Lingkaran
Application.ScreenUpdating = Benar
Keluar dari Sub
ErrHandler:
MsgBox "tidak ada file txt", , "Kutools for Excel"
End Sub
Komentar ini diminimalkan oleh moderator di situs
Hai, silakan coba kode di bawah ini
Sub Test()
'UpdatebyExtendoffice6/7/2016
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    xStrPath = "C:\Users\AddinsVM001\Desktop\test" 'Here is the parth you can modify
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
            On Error Resume Next
            ActiveSheet.Name = xWb.Name
            On Error GoTo 0
            xWb.Close False
        Next
    End If
End Sub

"C:\Users\AddinsVM001\Desktop\test" adalah jalur folder tempat Anda dapat mengimpor file teks, harap ubah sesuai kebutuhan.
Komentar ini diminimalkan oleh moderator di situs
Hai, terima kasih atas kode VBA Anda yang berharga.
Namun, saya memerlukan kode untuk beberapa file txt menjadi 'satu lembar di lembar kerja, bukan satu lembar untuk setiap file txt'.
Apa yang harus saya edit kode Anda untuk tujuan saya?

Terima kasih,
Komentar ini diminimalkan oleh moderator di situs
Hai, silakan coba kode di bawah ini
Sub Test()
    'UpdatebyExtendoffice 10/26/2022
    Dim xWb As Workbook
    Dim xToBook As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xFiles As New Collection
    Dim I As Long
    Dim J As Long
    Dim xRg As Range
    Dim xSaveRg As Range
    Dim xSh As Worksheet
    
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
    xFile = Dir(xStrPath & "*.txt")
    If xFile = "" Then
        MsgBox "No files found", vbInformation, "Kutools for Excel"
        Exit Sub
    End If
    Do While xFile <> ""
        xFiles.Add xFile, xFile
        xFile = Dir()
    Loop
    Set xToBook = ThisWorkbook
    Set xSh = xToBook.Sheets.Add
    Set xRg = xSh.Range("A1")
    J = 1
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If xFiles.Count > 0 Then
        For I = 1 To xFiles.Count
            Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
            Set xSaveRg = xWb.Worksheets(1).UsedRange
            J = xSaveRg.Rows.Count + 1 + J
            Debug.Print xRg.Address
            xSaveRg.Copy Destination:=xRg
            On Error Resume Next
            xWb.Close False
            
            Set xRg = xSh.Cells(J, 1)
        Next
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Belum ada komentar yang diposting di sini
Tinggalkan komentar anda
Posting sebagai Tamu
×
Beri peringkat pos ini:
0   Karakter
Lokasi yang Disarankan