Misalnya Anda memiliki 100 lembar data dan semua lembar kerja memiliki struktur yang sama. Yang kami inginkan adalah mendapatkan semua data beberapa lembar kerja dikonsolidasikan ke dalam satu lembar kerja. Lakukan dalam hitungan detik dengan kode berikut
Catatan. Kode ini mengasumsikan bahwa SEMUA lembar kerja memiliki struktur bidang yang sama; . Kode menyalin semua baris menjadi satu lembar kerja baru yang disebut Master.
Sub CopyFromWorksheets() Dim wrk As Workbook 'Workbook object - Always good to work with object variables Dim sht As Worksheet 'Object for handling worksheets in loop Dim trg As Worksheet 'Master Worksheet Dim rng As Range 'Range object Dim colCount As Integer 'Column count in tables in the worksheets Set wrk = ActiveWorkbook 'Working in active workbook For Each sht In wrk.Worksheets If sht.Name = "Master" Then MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _ "Please remove or rename this worksheet since 'Master' would be" & _ "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error" Exit Sub End If Next sht 'We don't want screen updating Application.ScreenUpdating = False 'Add new worksheet as the last worksheet Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count)) 'Rename the new worksheet trg.Name = "Master" 'Get column headers from the first worksheet 'Column count first Set sht = wrk.Worksheets(1) colCount = sht.Cells(1, 255).End(xlToLeft).Column 'Now retrieve headers, no copy&paste needed With trg.Cells(1, 1).Resize(1, colCount) .Value = sht.Cells(1, 1).Resize(1, colCount).Value 'Set font as bold .Font.Bold = True End With 'We can start loop For Each sht In wrk.Worksheets 'If worksheet in loop is the last one, stop execution (it is Master worksheet) If sht.Index = wrk.Worksheets.Count Then Exit For End If 'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount)) 'Put data into the Master worksheet trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value Next sht 'Fit the columns in Master worksheet trg.Columns.AutoFit 'Screen updating should be activated Application.ScreenUpdating = True End Sub
Cara Penggunaan
- Buka buku kerja yang berisi lembar kerja yang ingin Anda gabungkan
- Tekan Alt+F11 untuk membuka Visual Basic Editor (VBE)
- Dari menu, pilih Insert-Module
- Salin & Tempel kode di atas ke jendela kode di sebelah kanan
- Simpan file dan tutup VBE
Unduh File Sampel. Konsolidasikan Beberapa Lembar Kerja. xls
Baca juga
- Cara Membuka Proteksi Lembar Excel Tanpa Kata Sandi
- Menggabungkan beberapa file excel menjadi satu spreadsheet – VBA
- PivotTable Tingkat Lanjut. Menggabungkan Data dari Beberapa Lembar
- Cara Menggabungkan Teks dari Banyak Sel
- Lebih Banyak Alat & Tip VBA
Bagikan ini
- Surel
- Telegram
Terkait
Salah satu masalah umum dalam mengelola data adalah menyatukan semuanya. Katakanlah kita memiliki beberapa data yang tersebar di beberapa lembar yang ingin kita satukan dalam satu lembar. Bagaimana Anda akan melakukannya?
Salah satu caranya adalah menyalinnya dari beberapa lembar dan menempelkannya di satu lokasi atau yang lebih cerdas adalah dengan menulis makro sederhana untuk melakukan hal yang sama untuk kita.
Asumsikan kumpulan data ini
Kami telah menyebarkan data pada 5 lembar berbeda. Perhatikan juga bahwa tajuk dalam data adalah sama (itu adalah situasi yang lebih disukai)
Berikut adalah makro yang akan menggabungkan data
Sub combinedata() Dim var As Integer Dim sh As Worksheet var = 0 For Each sh In Worksheets If sh.Name = 'Consolidated Data' Then var = 1 Exit For End If Next sh If var = 0 Then Sheets.Add(Before:=Sheets(1)).Name = 'Consolidated Data' Else Sheets('Consolidated Data').Move Before:=Sheets(1) Sheets(2).Activate Sheets(2).Range(Range('a1'), Range('A1').End(xlToRight)).Copy Sheets(1).Activate Sheets('Consolidated Data').Paste Destination:=Range('a1') For Each sh In Worksheets If sh.Name <> ActiveSheet.Name Then With sh .Range('A2:N' & .Range('A' & Rows.Count).End(xlUp).Row).Copy _ Range('A' & Range('A' & Rows.Count).End(xlUp).Row + 1) End With End If Next sh ActiveWindow.DisplayGridlines = False Range('A1').CurrentRegion.Select Selection.Columns.AutoFit End Sub _>> Unduh buku kerja contoh dari bawah