Membagi lembar excel menjadi beberapa lembar berdasarkan nilai kolom vba

Question

@Mark Balhoff, Terima kasih atas masukan Anda yang berharga, saya selalu ingin belajar dan mendapatkan umpan balik untuk memperbaiki diri. ). Saya telah menggunakan masukan Anda dalam kode dan juga memperpanjangnya sedikit

Table of Contents Show

Bagaimana cara membagi lembar Excel menjadi beberapa lembar kerja berdasarkan kolom VBA?
Bagaimana cara membagi data menjadi beberapa lembar kerja berdasarkan kolom di Excel?
Bagaimana cara membagi data menjadi beberapa lembar kerja terpisah di Excel VBA?
Bagaimana cara membagi data dari satu lembar ke beberapa lembar di Excel?

Kode ini menggunakan kamus jadi Anda perlu mengaktifkan "Microsoft Scripting Runtime"

"Alat" -> "Referensi" -> "Microsoft Scripting Runtime" untuk membuat kamus berfungsi

Proses pengguna untuk membagi Data Master

Saya berasumsi bahwa pengguna akan membagi data ini dalam gambar. Menekan tombol, itu akan memilih kolom 7. (Pendapat saya adalah bagian ini dengan InputBox dll. tidak perlu karena Anda selalu ingin memfilter berdasarkan kolom 7, jadi saya merasa ini membingungkan pengguna akhir)

Cukup tidak jelas dari "data mentah" apa yang Anda mulai karena gambar/data baru telah muncul di pertanyaan yang diperbarui. Saya berasumsi bahwa data yang harus kita pisahkan terlihat seperti ini, seperti yang disebutkan pertama kali

Saya mencoba untuk mendapatkan kode yang saya temukan ini (dari Bagaimana membagi data menjadi beberapa lembar kerja berdasarkan kolom di Excel?) agar berfungsi, tetapi itu memberi saya kesalahan

Kode

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 4
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:I1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
End Sub

Ada ide tentang cara memperbaikinya?

terima kasih

kata waxsublime

Saya mencoba untuk mendapatkan kode yang saya temukan ini (dari Bagaimana membagi data menjadi beberapa lembar kerja berdasarkan kolom di Excel?) agar berfungsi, tetapi itu memberi saya kesalahan

Kode

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 4
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:I1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
   [COLOR=#ff0000] If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
 Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""[/COLOR]
    Else
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
End Sub

_

Ada ide tentang cara memperbaikinya?

terima kasih

Klik untuk meluaskan

Ada banyak kode lain yang melakukan hal semacam ini. Sebagian besar berjalan lebih cepat dan tanpa kesalahan

Jika karena alasan apa pun Anda antusias dengan hal di atas, maka ubah seperti yang ditunjukkan dengan warna merah, i. e. dalam versi Anda cukup tekan Enter setelah Lalu, jadi kode harus memiliki baris yang diakhiri dengan Lalu dan baris berikutnya dimulai dengan Lembar. Menambahkan

kata waxsublime
Wow, terima kasih banyak mirabeau. Itu bekerja seperti pesona

Apakah Anda memiliki versi favorit yang akan Anda rekomendasikan? . Saya ingin memeriksanya

Terima kasih lagi
Klik untuk meluaskan

Sangat tergantung pada data dan masalahnya
Anda dapat mencoba yang ini dan melihat apakah itu cocok untuk Anda

Kode

Sub columntosheets() 

Const sname As String = "Sheet1" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With
For Each sh In Worksheets
    d(sh.Name) = 1
Next sh

Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
    If a(i, 1) <> a(p, 1) Then
        If d(a(p, 1)) <> 1 Then
            Sheets.Add.Name = a(p, 1)
            .Cells(1).Resize(, cls).Copy Cells(1)
            .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
        End If
        p = i
    End If
Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate

End Sub

kata waxsublime
Terima kasih mirabeau. Makro itu BANYAK lebih cepat. Tapi itu memberi saya kesalahan pada nama lembar itu

Durasi 1004
Nama tidak boleh melebihi 31 karakter
nama tidak boleh berisi karakter. . /\?*
Anda tidak mengosongkan nama

Makro lain tidak memberikan kesalahan, tetapi saya juga belum memeriksa untuk melihat apakah semuanya berjalan dengan benar. Bagaimanapun, terima kasih lagi
Klik untuk meluaskan

Kode di Post#4 bertujuan untuk memberi nama sheet baru setelah item unik di Kolom A

Jika salah satu atau semua item ini memiliki lebih dari 31 karakter (katakanlah karena mengandung karakter non-cetak atau alasan lain) maka Excel tidak akan melakukan ini

Kode yang awalnya Anda posting juga tidak. Kode itu hanya mem-bypass kesalahan dengan memasukkan baris "On Error Resume Next" sekitar setengah jalan, dalam hal ini lembar baru hanya diberi nomor lembar

Jika Anda ingin kode yang saya posting juga melewati kesalahan dan menghasilkan hasil yang sama, maka sertakan juga "On Error Resume Next" sekitar setengah jalan (katakanlah tepat sebelum baris "a =. Sel (cc). Ubah ukuran(rws + 1, 1)")

Secara pribadi saya lebih suka untuk tidak mengikuti pendekatan itu. Jika ada potensi kesalahan, yang disebabkan oleh tipe data atau apa pun, preferensi saya untuk melihat apa kesalahan itu dan kemudian mengambil tindakan perbaikan, daripada secara otomatis melewati setiap dan semua kesalahan

Dalam kasus Anda, saya tidak tahu jenis data apa yang Anda miliki, karena sering kali ketika melakukan hal semacam ini, diperlukan beberapa dugaan untuk data Anda dan sifat hasil yang Anda inginkan.

kata fjlaff
Hi mirabeau,

Saya baru di sini dan seorang pemula yang lengkap dengan makro. Kode yang Anda posting telah berfungsi untuk saya, namun semua nama dalam urutan terbalik, dan ada beberapa fungsi lain yang perlu saya tambahkan. Akan sangat membantu jika Anda bisa menjelaskan setiap langkah makro sehingga saya bisa menyesuaikan dari sana

Salam,
Takut
Klik untuk meluaskan

hai Fearghas,

selamat datang di forum

Saya tidak yakin apa yang Anda maksud dengan "semua nama dalam urutan terbalik"

Jika colA adalah kolom awal atau kriteria Anda, dan Anda memiliki A, B, C yang tercantum di bawahnya, maka kode itu akan menghasilkan dan mencantumkan lembar baru bernama A, B, dan C, dalam urutan itu

jika Anda seorang pemula yang "lengkap", ini adalah makro yang cukup rumit untuk dijelaskan, dan mungkin lebih baik jika Anda membiasakan diri dengan beberapa yang lebih sederhana terlebih dahulu

juga, seperti disebutkan di atas, ada berbagai kode vba yang melakukan hal semacam ini. misalnya di link ini

http. // www. mrexcel. com/forum/excel-. kriteria berbasis s-move-rows-lain-lembar. html
http. // www. mrexcel. com/forum/excel-questions/328460-copy-various-duplicate-rows-new-sheet. html

dan banyak tempat lain

Bagaimana cara membagi lembar Excel menjadi beberapa lembar kerja berdasarkan kolom VBA?

Panduan langkah demi langkah tentang cara membagi lembar excel. .

Langkah 1. Tekan Alt + F11 untuk membuka editor VBA

Langkah 2. Sisipkan Modul dari Sisipkan modul

Langkah 3. Salin kode di bawah ini dan tempel di jendela kode

Langkah 4. Tekan F5 untuk mengeksekusi kode VBA di bawah ini

Bagaimana cara membagi data menjadi beberapa lembar kerja berdasarkan kolom di Excel?

Untuk membagi rentang data menjadi beberapa lembar kerja tergantung kolom, harap pilih rentang terlebih dahulu. Kemudian, dengan memilih Beranda > Lembar Kerja > Pisahkan Data , gunakan alat.

Bagaimana cara membagi data menjadi beberapa lembar kerja terpisah di Excel VBA?

Langkah-Langkah Membagi Data Menjadi Beberapa Lembar Kerja .

Langkah 1. Buat Makro Baru di Modul VBA. Pilih tab Pengembang. Sekarang, klik Rekam Makro dari perintah. Dapatkan jendela baru, Rekam Makro. .

Langkah 2. Simpan File dalam Format XLSM dan Jalankan Makro. Kemudian tekan F5 untuk menjalankan kode. Akan muncul kotak dialog untuk menginputkan angka

Bagaimana cara membagi data dari satu lembar ke beberapa lembar di Excel?

Pilih di bawah baris tempat Anda ingin memisahkan, atau kolom di sebelah kanan tempat Anda ingin memisahkan. Pada tab Tampilan, di grup Jendela, klik Pisahkan . Untuk menghapus panel pemisah, klik Pisahkan lagi.

kode excel