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
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
@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.
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
@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.
maaf om ada sedikit masalah lagi
ketika di kolom Data ada yg tidak terisi,, maka hasilnya jadi seperti dibawah ini :
apakah bisa supaya header tidak ikut terambil / tercopy ketika datanya kosong
@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.