Rumus VBA & Macro Excel

  1. 3 bulan yang lalu

    Selamat siang, saya mau tanya ne...saya punya data pemilih dalam satu work sheet dan saya mau buat kolektif dalam satu sheet, setelah saya gabung kedalam satu sheet ternyata Nomor NIK & NKK berubah pada digit ke-16 yakni angka 0 semua.
    Bagaimana caranya supaya tidak berubah Nomor NIK & NKK?
    Sekian mohon pencerahan..!

    Copy aja salah satu header ke Sheet "Hasil" kemudian gunakan skrip berikut :

    Sub GabungSheet()
       Application.ScreenUpdating = False
        Dim wrk As Workbook
        Dim sht As Worksheet
        Dim trg As Worksheet
        Dim rng As Range
        Set wrk = ActiveWorkbook
        Set trg = Sheets("Hasil")
        For Each sht In wrk.Worksheets
            If sht.Name <> trg.Name And sht.Name <> "REKAP DPSHP KECAMATAN" Then
            Set rng = sht.Range("A11:N" & sht.Range("A" & Rows.Count).End(xlUp).Row)
            rng.Copy
            trg.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial
            End If
        Next sht
        
        trg.Columns.AutoFit
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End Sub

  2. manweljs_

    Jul 21 Terverifikasi + 5.184 Poin

    @Luthfi Aliffatuzzain

    apakah ada file yang bisa dilampirkan? agar bisa diperiksa errornya dimana.

  3. Di sunting 3 bulan yang lalu oleh Luthfi Aliffatuzzain

    @manweljs_
    Ini module VBA yg saya gunakan!

  4. manweljs_

    Jul 21 Terverifikasi + 5.184 Poin
    Di sunting 3 bulan yang lalu oleh manweljs_

    coba ganti rng.value menjadi rng.text

    Option Explicit
    
    Sub gabung_sheet()
       Application.ScreenUpdating = False
        Dim wrk As Workbook
        Dim sht As Worksheet
        Dim trg As Worksheet
        Dim rng As Range
        Dim colCount As Integer
        Set wrk = ActiveWorkbook
        For Each sht In wrk.Worksheets
            If sht.Name = "Hasil" Then
                MsgBox "Worksheet 'Hasil' sudah ada ." & vbCrLf & _
                "silahkan di delete dulu karena sheet 'Hasil' " & _
                "akan menjadi hasil dari penggabugan ini.", vbOKOnly + vbExclamation, "Error"
                Exit Sub
            End If
        Next sht
        Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
        trg.Name = "Hasil"
        Set sht = wrk.Worksheets(1)
        colCount = sht.Cells(1, 255).End(xlToLeft).Column
        With trg.Cells(1, 1).Resize(1, colCount)
            .Value = sht.Cells(1, 1).Resize(1, colCount).Value
            .Font.Bold = True
        End With
        For Each sht In wrk.Worksheets
            If sht.Index = wrk.Worksheets.Count Then
                Exit For
            End If
            Set rng = sht.Range(sht.Cells(10, 1), sht.Cells(65536, 22).End(xlUp).Resize(, colCount))
    
         'Ganti jadi text
            trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).text = rng.text
         
        Next sht
        trg.Columns.AutoFit
        Application.ScreenUpdating = True
    End Sub

  5. @manweljs_
    Saya coba ganti tapi malah tidak ada hasil yang digabungkan!

  6. @manweljs_
    Hasil yg pertama jika saya ganti menjadi value! pada digit ke-16 terdapat angka 0 semua yg tidak sesuai dengan data real

  7. manweljs_

    Jul 21 Terverifikasi + 5.184 Poin

    @Luthfi Aliffatuzzain

    coba dilampirkan file yang sedang dikerjakan. setidaknya 2 sheet data dan masing2 sheet berisi 20 row itu sudah cukup untuk menganalisa susunan filenya.

  8. @manweljs_
    Datanya seperti ini!

  9. manweljs_

    Jul 21 Terverifikasi + 5.184 Poin
    Di sunting 3 bulan yang lalu oleh manweljs_

    @Luthfi Aliffatuzzain

    coba edit menjadi :

    ....
        For Each sht In wrk.Worksheets
            If sht.Index = wrk.Worksheets.Count Then
                Exit For
            End If
            Set rng = sht.Range(sht.Cells(10, 1), sht.Cells(65536, 22).End(xlUp).Resize(, colCount))
            rng.Copy
            trg.Cells(65536, 1).End(xlUp).Offset(1).PasteSpecial
            
        Next sht
    ....

    note : Data yang anda lampirkan dimulai dari row ke 4, sedangkan skrip anda mulai "mengcopy" dari row ke-10. jadi saya berasumsi masih ada data lain di baris 1-6 yang mungkin anda hapus pada lampiran.

  10. @manweljs_
    Alhamdulillah sudah berhasil... Terimakasih ya

  11. manweljs_

    Jul 21 Terverifikasi + 5.184 Poin
    Di sunting 3 bulan yang lalu oleh manweljs_

    @Luthfi Aliffatuzzain

    berhasil ya ... sukurlah :D
    terlampir contoh file yg sy edit sedikit skripnya dengan susunan data berdasarkan lampiran yang anda berikan

  12. @manweljs_
    Ya berhasil, next untuk dijadikan satu headernya maka yg kita rubah yg mana ne?

  13. @manweljs_
    Misalnya dari sekian sheet yg saya kerjakan header tabelnya sama dan saya mau buat satu header. seperti contoh dibawah ini...maka rumus yg dirubah pada module VBA yg mana ne?

  14. manweljs_

    Jul 21 Terverifikasi + 5.184 Poin

    @Luthfi Aliffatuzzain

    triknya adalah dibuat dulu sheet Hasil nya (contoh terlampir)

  15. @manweljs_
    Ya seperti contoh yang dikirmkan, pada module VBA yg dirubah yg mana atau memang ada module tersendiri yg dibuatnya oleh @manweljs_ !

  16. manweljs_

    Jul 21 Terverifikasi Jawaban Terpilih + 5.184 Poin
    Di sunting 3 bulan yang lalu oleh manweljs_

    Copy aja salah satu header ke Sheet "Hasil" kemudian gunakan skrip berikut :

    Sub GabungSheet()
       Application.ScreenUpdating = False
        Dim wrk As Workbook
        Dim sht As Worksheet
        Dim trg As Worksheet
        Dim rng As Range
        Set wrk = ActiveWorkbook
        Set trg = Sheets("Hasil")
        For Each sht In wrk.Worksheets
            If sht.Name <> trg.Name And sht.Name <> "REKAP DPSHP KECAMATAN" Then
            Set rng = sht.Range("A11:N" & sht.Range("A" & Rows.Count).End(xlUp).Row)
            rng.Copy
            trg.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial
            End If
        Next sht
        
        trg.Columns.AutoFit
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End Sub

 

atau Mendaftar untuk ikut berdiskusi!