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

Bagaimana cara mengulang file dalam direktori dan menyalin data ke dalam lembar master di Excel?

Misalkan ada beberapa buku kerja Excel dalam satu folder, dan Anda ingin mengulang semua file Excel ini dan menyalin data dari rentang lembar kerja nama yang sama ke dalam lembar kerja master di Excel, apa yang dapat Anda lakukan? Artikel ini memperkenalkan metode untuk mencapainya secara detail.

Ulangi file dalam direktori dan salin data ke dalam lembar master dengan kode VBA


Ulangi file dalam direktori dan salin data ke dalam lembar master dengan kode VBA


Jika Anda ingin menyalin data yang ditentukan dalam rentang A1: D4 dari semua lembar1 buku kerja dalam folder tertentu ke lembar master, lakukan hal berikut.

1. Di buku kerja Anda akan membuat lembar kerja master, tekan lain + F11 kunci untuk membuka Microsoft Visual Basic untuk Aplikasi jendela.

2. Dalam Microsoft Visual Basic untuk Aplikasi window, klik Menyisipkan > Modul. Kemudian salin kode VBA di bawah ini ke jendela kode.

Kode VBA: loop melalui file dalam folder dan salin data ke dalam lembar master

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Note:

1). Dalam kode, "A1: D4"Dan"Sheet1”Artinya data dalam range A1: D4 dari semua Sheet1 akan disalin ke dalam master sheet. Dan "Sheet Baru”Adalah nama dari master sheet yang baru dibuat.
2). File Excel di folder tertentu tidak boleh terbuka.

3. tekan F5 kunci untuk menjalankan kode.

4. Dalam pembukaan Browse jendela, pilih folder yang berisi file yang akan Anda putar, lalu klik OK tombol. Lihat tangkapan layar:

Kemudian lembar kerja utama bernama "Lembar Baru" dibuat di akhir buku kerja saat ini. Dan data dalam rentang A1: D4 dari semua Sheet1 di folder yang dipilih tercantum di dalam lembar kerja.


Artikel terkait:


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 (18)
Belum ada peringkat. Jadilah yang pertama memberi peringkat!
Komentar ini diminimalkan oleh moderator di situs
terima kasih atas kode vbanya! Ini bekerja dengan sempurna! Ingin tahu apa kodenya jika saya perlu PASTE AS VALUE? Thx sebelumnya!
Komentar ini diminimalkan oleh moderator di situs
Hai Lai Ling,
Kode berikut dapat membantu Anda memecahkan masalah. Terima kasih atas komentarmu.

Sub Merge2MultiSheets()
Redupkan xRg Sebagai Rentang
Redupkan xSelItem Sebagai Varian
Redupkan xFileDlg Sebagai FileDialog
Redupkan xFileName, xSheetName, xRgStr Sebagai String
Redupkan xBook, xWorkBook Sebagai Buku Kerja
Redupkan xSheet Sebagai Lembar Kerja
On Error Resume Next
Application.DisplayAlerts = Salah
Application.EnableEvents = Salah
Application.ScreenUpdating = Salah
xSheetName = "Sheet1"
xRgStr = "A1:D4"
Setel xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Dengan xFileDlg
Jika .Tunjukkan = -1 Maka
xSelItem = .SelectedItems.Item(1)
Setel xWorkBook = Buku Kerja Ini
Setel xSheet = xWorkBook.Sheets("Lembar Baru")
Jika xSheet Bukan Apa-apa, Maka
xWorkBook.Sheets.Add(setelah:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Nama = "Lembar Baru"
Setel xSheet = xWorkBook.Sheets("Lembar Baru")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Jika xFileName = "" Kemudian Keluar dari Sub
Lakukan Hingga xFileName=""
Setel xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Tetapkan xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Salin xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBuku.Tutup
Lingkaran
End If
Berakhir dengan
Tetapkan xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Benar
xRg.UseStandardWidth = Benar
Application.DisplayAlerts = Benar
Application.EnableEvents = Benar
Application.ScreenUpdating = Benar
End Sub
Komentar ini diminimalkan oleh moderator di situs
Hai, terima kasih atas kodenya. Tolong bisakah Anda memberi tahu saya bagaimana saya bisa memasukkan nama file Excel dari mana rentang data disalin? Ini akan sangat membantu!

Terima kasih.
Komentar ini diminimalkan oleh moderator di situs
Halo,

Terima kasih untuk tutorialnya.

Bagaimana saya: Hanya salin baris di "Sheet1" dengan nilai dari baris "total" dan tempel dengan [nama file] di lembar kerja master bernama "Lembar Baru". Mencatat baris dengan Total bisa berbeda di setiap lembar kerja.

Sebagai contoh:
File1: Lembar1
Kol1, Kol2, Kolx
1,2,15
Hasil,10,50

File2: Lembar1
Kol1, Kol2, Kolx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Hasil,300,500

MasterFile: "Lembar Baru":
file1, 10, 50
file2, 300, 500
Komentar ini diminimalkan oleh moderator di situs
Halo, Ini berfungsi dengan baik. Apakah ada cara untuk mengubah hanya dengan menarik nilai dan bukan formula?
Terima kasih!!
Komentar ini diminimalkan oleh moderator di situs
Hai Trish,
Kode berikut dapat membantu Anda memecahkan masalah. Terima kasih atas komentarmu.

Sub Merge2MultiSheets()
Redupkan xRg Sebagai Rentang
Redupkan xSelItem Sebagai Varian
Redupkan xFileDlg Sebagai FileDialog
Redupkan xFileName, xSheetName, xRgStr Sebagai String
Redupkan xBook, xWorkBook Sebagai Buku Kerja
Redupkan xSheet Sebagai Lembar Kerja
On Error Resume Next
Application.DisplayAlerts = Salah
Application.EnableEvents = Salah
Application.ScreenUpdating = Salah
xSheetName = "Sheet1"
xRgStr = "A1:D4"
Setel xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Dengan xFileDlg
Jika .Tunjukkan = -1 Maka
xSelItem = .SelectedItems.Item(1)
Setel xWorkBook = Buku Kerja Ini
Setel xSheet = xWorkBook.Sheets("Lembar Baru")
Jika xSheet Bukan Apa-apa, Maka
xWorkBook.Sheets.Add(setelah:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Nama = "Lembar Baru"
Setel xSheet = xWorkBook.Sheets("Lembar Baru")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Jika xFileName = "" Kemudian Keluar dari Sub
Lakukan Hingga xFileName=""
Setel xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Tetapkan xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Salin xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBuku.Tutup
Lingkaran
End If
Berakhir dengan
Tetapkan xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Benar
xRg.UseStandardWidth = Benar
Application.DisplayAlerts = Benar
Application.EnableEvents = Benar
Application.ScreenUpdating = Benar
End Sub
Komentar ini diminimalkan oleh moderator di situs
Hai, itu masih menarik rumusnya, bukan nilainya, jadi ini memberi saya kesalahan #REF. Saya tahu ini mungkin memerlukan .PasteSpecial xlPasteValues ​​di suatu tempat, tetapi saya tidak tahu di mana. Bisakah kamu menolong? Terima kasih!
Komentar ini diminimalkan oleh moderator di situs
Hai Terima kasih untuk ini.


Bagaimana cara memasukkan kode untuk mengulang semua folder dan subfolder dan melakukan salinan di atas?


Terima kasih!
Komentar ini diminimalkan oleh moderator di situs
Hai - Kode ini sangat cocok untuk apa yang saya coba capai.

Apakah ada cara untuk mengulang semua folder dan subfolder dan melakukan penyalinan?


Terima kasih!
Komentar ini diminimalkan oleh moderator di situs
Hai - Kode ini bekerja sangat baik untuk 565 baris pertama untuk setiap file, tetapi semua baris setelahnya tumpang tindih dengan file berikutnya.
apakah ada cara untuk memperbaiki ini?
Komentar ini diminimalkan oleh moderator di situs
Terima kasih - bagaimana seseorang dapat menyalin dan menempel (nilai khusus) dari setiap lembar kerja dalam buku kerja ke lembar terpisah dalam file Master utama?
Komentar ini diminimalkan oleh moderator di situs
bagaimana Anda membuat kode biarkan kosong jika sel kosong?
Komentar ini diminimalkan oleh moderator di situs
bagi saya, nama tab "Sheet1" berubah untuk setiap file saya. Misalnya, Tab1, Tab2, Tab3, Tab4...Bagaimana saya bisa mengatur loop untuk menjalankan daftar di excel dan terus mengubah nama "Sheet1" sampai menjalankan semuanya?
Komentar ini diminimalkan oleh moderator di situs
Hai Nick, Kode VBA di bawah ini dapat membantu Anda memecahkan masalah. Silakan coba. Sub LoopThroughFileRename()
'Diperbarui oleh Extendofice 2021/12/31
Redupkan xRg Sebagai Rentang
Redupkan xSelItem Sebagai Varian
Redupkan xFileDlg Sebagai FileDialog
Redupkan xFileName, xSheetName, xRgStr Sebagai String
Redupkan xBook, xWorkBook Sebagai Buku Kerja
Redupkan xSheet Sebagai Lembar Kerja
Redupkan xShs Sebagai Lembar
Redupkan xName As String
Redupkan xFNum Sebagai Integer
On Error Resume Next
Application.DisplayAlerts = Salah
Application.EnableEvents = Salah
Application.ScreenUpdating = Salah
Setel xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Tampilkan
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Lakukan Sementara xFileName <> ""
Setel xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Tetapkan xShs = xWorkBook.Sheets
Untuk xFNum = 1 Sampai xShs.Count
Setel xSheet = xShs.Item(xFNum)
xName = xSheet.Nama
xNama = Ganti(xNama, "lembar""Tab") 'Ganti Lembar dengan Tab
xSheet.Nama = xNama
Next
xWorkBook.Simpan
xWorkBook.Tutup
xFileName = Dir()
Lingkaran
Application.DisplayAlerts = Benar
Application.EnableEvents = Benar
Application.ScreenUpdating = Benar
End Sub
Komentar ini diminimalkan oleh moderator di situs
Hai saya ingin kode untuk menyalin data dalam 6 buku kerja yang berbeda (dalam folder) yang memiliki lembar yang disertakan di dalamnya ke BUKU KERJA BARU. di vba
tolong bantu saya asp
Komentar ini diminimalkan oleh moderator di situs
Hai Paranusa,
Skrip VBA dalam artikel berikut ini dapat menggabungkan beberapa buku kerja atau lembar buku kerja tertentu ke buku kerja master. Silakan periksa apakah itu dapat membantu.
Bagaimana Menggabungkan Beberapa Buku Kerja Menjadi Satu Buku Kerja Master Di Excel?
Komentar ini diminimalkan oleh moderator di situs
Dia baik-baik saja.
Setelah beberapa hari, saya tidak tahu tentang hubungan yang saya impreimir dengan tepat.
Preciso imprimir 2.400 relatório de exel que estão em pastas diferentes e não estão configuradas corretamente para impresio. Buat saya enviar um códgo de VBA que mengotomatisasi essa mengesankan ? Saya ajudaria muito, obrigada.
Komentar ini diminimalkan oleh moderator di situs
Skenario saya serupa, kecuali saya memiliki banyak lembar di setiap file, semuanya dengan nama berbeda tetapi konsisten antar file. Apakah ada cara untuk mengulang kode ini untuk menyalin data di dalam file dan menempelkan (nilai) ke nama lembar tertentu di buku kerja utama? Nama sheet di master sama dengan di file. Saya ingin mengulanginya. Selain itu, jumlah data di setiap lembar akan bervariasi, jadi saya harus memilih data di setiap lembar menggunakan sesuatu seperti ini:

Rentang("A1").Pilih
Rentang(Pilihan, Pilihan.End(xlDown)).Pilih
Rentang(Pilihan, Pilihan.End(xlToRight)).Pilih


Nama lembar file adalah Pemberian, Jasa, Asuransi, Mobil, Pengeluaran Lain, dll...

Terima kasih sebelumnya.
Belum ada komentar yang diposting di sini
Tinggalkan komentar anda
Posting sebagai Tamu
×
Beri peringkat pos ini:
0   Karakter
Lokasi yang Disarankan