@david leo mohon bantuannya para master

Untuk mengisi kolom KETERANGAN, mas @David Leo bisa mencoba menggunakan script seperti berikut:

Public Sub IsiKeterangan()
    Dim xlRange As Range, xlCell As Range
    Dim sValue As String
    Dim lSkip As Long
    
    Application.ScreenUpdating = False
    
    '+-- Range target yang akan diperiksa.
    Set xlRange = Sheet2.Range("A2:A51")
    
    For Each xlCell In xlRange
        If xlCell <> "" Then
            '+-- Jika kolom KETERANGAN tidak kosong,
            '+-- simpan nilai untuk sel berikutnya.
            sValue = xlCell
            lSkip = 0
        Else
            If Len(xlCell.Offset(0, 1)) Then
                '+-- Jika kolom NILAI tidak kosong,
                '+-- isi kolom KETERANGAN.
                xlCell = sValue
            Else
                lSkip = lSkip + 1
                '+-- Keluar pengulangan jika sel
                '+-- yang diproses kosong.
                If lSkip > 3 Then Exit For
            End If
        End If
    Next
    
    Application.ScreenUpdating = True
    
End Sub

Demikian, selamat mencoba.

@david leo ... jika nilaI range AKHIR kolom "A" tidak ditentukan seprti script dari mas caton tersebut yang (a2:A51), cuman aya mengacu kepada kolom range B akhir gimana ...

Maaf, script di atas ada kesalahan pada penentuan range target, seharusnya merujuk ke kolom B. Jadi ubah scriptnya menjadi:

Public Sub IsiKeterangan()
    Dim xlRange As Range, xlCell As Range
    Dim sValue As String, sFormula As String
    Dim lSkip As Long
    
    Application.ScreenUpdating = False
    
    With Sheet1
        Set xlRange = .Range("A2:A" & .Cells(.Rows.Count, "B").End(xlUp).Row)
    End With
    
    For Each xlCell In xlRange
        If xlCell = "" Then
            If Len(xlCell.Offset(0, 1)) Then
                xlCell.Offset(-1, 0).Copy xlCell
            End If
        End If
    Next
    
    Application.ScreenUpdating = True    
End Sub

@david leo ... kemudian jika cell a1 tersebut merupakan hasil formulla ,dan supaya kolom a2 sd setrus'na tercopy dan berisi cells2 na formula juga gimana ...

Revisi script di atas akan menyalin formula dari sel di atas sel yang aktif.

Demikian.

@david leo ... you are the best ... makasih atas bantuan dan ilmu'nya ...

You're the best too. Sama-sama ... :)

@david leo ... case'na hampir sama ...

Scriptnya juga hampir sama, ± seperti berikut:

Sub Button1_Click()
    Dim xlRange As Range

    Application.ScreenUpdating = False

    With Sheet1
        For Each xlRange In .Range("B2:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
            If Len(xlRange) Then
                If Len(xlRange.Offset(0, 1)) = 0 Then
                    xlRange.Offset(-1, 1).Resize(1, 2).Copy xlRange.Offset(0, 1)
                End If
            End If
        Next
    End With

    Application.ScreenUpdating = True

End Sub

atau bisa juga seperti berikut:

Sub Button1_Click()
    Dim xlRange As Range

    Application.ScreenUpdating = False

    With Sheet1
        For Each xlRange In .Range("B2:B" & 10 ^ 6)
            If Len(xlRange) Then
                If Len(xlRange.Offset(0, 1)) = 0 Then
                    xlRange.Offset(0, 1).Resize(1, 2).FillDown
                End If
            Else
                Exit For
            End If
        Next
    End With

    Application.ScreenUpdating = True

End Sub

Demikian.

@david leo ... SCRIPT diatas APA AYA UNTUK TERCOPY 2 COLOM JA GAK BISA LEBIH JIKA ADA KOLOM YANG LAINNA LAGI?? ...

Kalau mau menambah atau memperlebar kolom yang akan dicopy, khan tinggal diresize saja kolomnya. Misalkan untuk sheet CASE 1, kolom yang akan disalin adalah mulai kolom C sampai dengan kolom G:

Sub Button1_Click()
 Dim xlRange As Range

    Application.ScreenUpdating = False

    With Sheet1
        For Each xlRange In .Range("B2:B" & 10 ^ 6)
            If Len(xlRange) Then
                If Len(xlRange.Offset(0, 1)) = 0 Then
                    xlRange.Offset(0, 1).Resize(1, 5).FillDown
                End If
            Else
                Exit For
            End If
        Next
    End With

    Application.ScreenUpdating = True
End Sub

Sedangkan untuk sheet CASE 2, dengan tambahan kolom I sampai dengan kolom K, maka geser kembali range pada variabel xlRange ke kolom I kemudian diresize sejumlah 3 kolom:

Sub Button2_Click()
 Dim xlRange As Range

    Application.ScreenUpdating = False

    With Sheet2
        For Each xlRange In .Range("B2:B" & 10 ^ 6)
            If Len(xlRange) Then
                If Len(xlRange.Offset(0, 1)) = 0 Then
                    xlRange.Offset(0, 1).Resize(1, 5).FillDown
                    xlRange.Offset(0, 7).Resize(1, 3).FillDown
                End If
            Else
                Exit For
            End If
        Next
    End With

    Application.ScreenUpdating = True
End Sub

Demikian.

mas @Caton izin nimbrung lagi yak :)

@david leo

atau bisa juga untuk Case 1 :

With Sheet1
x = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("C2:G2").Copy .Range("C3:G" & x)
End With

---  atau  ---

With Sheet1
x = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("C3:G" & x) = .Range("C2:G2").Value
End With

untuk Case 2 :

With Sheet2
x = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("C2:K2").Copy .Range("C3:K" & x)
End With

---  atau  ---

With Sheet2
x = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("C3:K" & x) = .Range("C2:K2").Value
End With

@david leo koreksi dikit @manweljs_ ^_^
kokk..hasil copy cells range tersebut gak ada formula'nya

dimana case tersebut merupakan copy'an berisi formula..,

contohnya bukan formula sih :)

kalo gitu pakai aja yg pertama (yg gak ada .Value nya )

atau bisa seperti ini :

With Sheet1
x = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("C2:G2").Copy 
    .Range("C3:G" & x).PasteSpecial xlPasteFormulas
Application.CutCopyMode = False
End With