Copy paste duplikat

  1. 5 bulan yang lalu

    selamat siang master BE.Org semua

    Mungkin ada yg bisa membantu ,
    jadi saya ingin menduplikat sebuah data di kolom A sebanyak dengan nilai yang sudah di tetapkan
    Untuk lebih detailnya saya sertakan lampiran

    Terima kasih

  2. Caton

    Jul 7 Terverifikasi Indonesia + 17.741 Poin

    @anggun123 ...

    Berikut contoh script yang bisa dicoba :

    Public Sub DuplicateData()
        Dim vData As Variant, vResult As Variant
        Dim lDupCount As Long, lTotal As Long, lIdx As Long, lR As Long
        Dim sValue As String
        
        '+-- Jumlah duplikasi.
        lDupCount = 3
        
        '+-- Tentukan baris akhir data pada kolom A!
        lR = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
        '+-- Asumsi data mulai sel A4, simpan data ke array.
        vData = Sheet1.Range("A4:A" & lR).Value2
        
        '+-- Dimensi penampung data yang dibutuhkan.
        lTotal = UBound(vData) * lDupCount
        '+-- Siapkan penampung hasil.
        ReDim vResult(0 To lTotal - 1)
        
        lIdx = 1
        For lR = 1 To lTotal
            '+-- Isi penampung dengan data.
            vResult(lR - 1) = vData(lIdx, 1)
            If lR Mod 3 = 0 Then lIdx = lIdx + 1
        Next
        
        '+-- Transfer array ke range (Data yang ada akan ditimpa!!!)
        Sheet1.Range("A4").Resize(RowSize:=lTotal).Value2 = Application.Transpose(vResult)
    End Sub

    Demikian.

  3. terima kasih om @Caton
    sesuai harapan

    saya coba edit di skrip bagian ini

    vData = Sheet1.Range("A4:A" & lR).Value2

    menjadi

    vData = Sheet1.Range("A4:D" & lR).Value2

    karena di data saya kolom sampai D , tapi tidak berhasil
    kira2 edit dimananya lagi yaa om :) agar data sampai kolom D juga bisa terduplikat

  4. Caton

    Jul 7 Terverifikasi Indonesia + 17.741 Poin
    Di sunting 5 bulan yang lalu oleh Caton

    @anggun123 ...

    Scriptnya lebih kurang jadi seperti berikut :

    Public Sub DuplicateData()
        Dim lDupCount As Long, lTotal As Long, lIdx As Long, lR As Long, lC As Long
        Dim vData As Variant, vResult As Variant
        Dim sValue As String
        
        '+-- Jumlah duplikasi.
        lDupCount = 3
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        '+-- Loop 4 kolom.
        For lC = 1 To 4
            '+-- Tentukan baris akhir data pada setiap kolom!
            lR = Sheet1.Cells(Rows.Count, lC).End(xlUp).Row
            '+-- Ambil data per kolom. Jika lC = 3 dan lR = 15, maka
            '+-- Cells(4, lC) = "C4" dan Cells(lR, lC) = "C15"
            vData = Sheet1.Range(Cells(4, lC), Cells(lR, lC)).Value2
        
            '+-- Dimensi penampung data yang dibutuhkan.
            lTotal = UBound(vData) * lDupCount
            '+-- Siapkan penampung hasil.
            ReDim vResult(0 To lTotal - 1)
            
            lIdx = 1
            For lR = 1 To lTotal
                '+-- Isi penampung dengan data.
                vResult(lR - 1) = vData(lIdx, 1)
                If lR Mod 3 = 0 Then lIdx = lIdx + 1
            Next
            
            '+-- Transfer array ke range (Data yang ada akan ditimpa!!!)
            Sheet1.Cells(4, lC).Resize(RowSize:=lTotal).Value2 = Application.Transpose(vResult)
        Next
        
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub

    Demikian.

  5. maaf om ada sedikit masalah lagi

    ketika di kolom Data ada yg tidak terisi,, maka hasilnya jadi seperti dibawah ini :

    Screenshot_1.png

    apakah bisa supaya header tidak ikut terambil / tercopy ketika datanya kosong

  6. Caton

    Jul 7 Terverifikasi Indonesia + 17.741 Poin

    @anggun123 ...

    Bisa saja, tinggal tambahkan blok IF agar jika data kosong, proses lanjut ke kolom berikutnya atau selesai.

    Public Sub DuplicateData()
        Dim lDupCount As Long, lTotal As Long, lIdx As Long, lR As Long, lC As Long
        Dim vData As Variant, vResult As Variant
        Dim sValue As String
        
        '+-- Jumlah duplikasi.
        lDupCount = 3
        
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        
        '+-- Loop 4 kolom.
        For lC = 1 To 4
            '+-- Tentukan baris akhir data pada kolom A!
            lR = Sheet1.Cells(Rows.Count, lC).End(xlUp).Row
            '+-- 3 merupakan baris header.
            If lR > 3 Then
                '+-- Ambil data per kolom. Jika lC = 3 dan lR = 15, maka
                '+-- Cells(4, lC) = "C4" dan Cells(lR, lC) = "C15"
                vData = Sheet1.Range(Cells(4, lC), Cells(lR, lC)).Value2
            
                '+-- Dimensi penampung data yang dibutuhkan.
                lTotal = UBound(vData) * lDupCount
                '+-- Siapkan penampung hasil.
                ReDim vResult(0 To lTotal - 1)
                
                lIdx = 1
                For lR = 1 To lTotal
                    '+-- Isi penampung dengan data.
                    vResult(lR - 1) = vData(lIdx, 1)
                    If lR Mod 3 = 0 Then lIdx = lIdx + 1
                Next
                
                '+-- Transfer array ke range (Data yang ada akan ditimpa!!!)
                Sheet1.Cells(4, lC).Resize(RowSize:=lTotal).Value2 = Application.Transpose(vResult)
            End If
        Next
        
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub

    Demikian.

 

atau Mendaftar untuk ikut berdiskusi!