Soru Worksheet Change kullanılan sayfada kopyalama yapma.

[ndako]

Merhaba vba ile bir sipariş takip programı oluşturmaya çalışıyorum. Aşağıdaki kodu kullanara C sütununa bir müşteri ismi yazıldığında A ve B sütunlarına otomatik olarak sıra numarası ve sipariş numarası atıyor. Bu şekilde tek tek her satırda çalışıyor fakat aynı müşteriye ait 10 satır sipariş olduğunda tek tek yazmak yerine C sütunundaki ismi aşağıya doğru 10 satır kopyala yapıştır yapmak istediğimde kod hata veriyor. Bu şekilde kopyala yaptığımda çalışır hale nasıl getiririm bu kodu. Teşekkürler.

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Value = "" Then Exit Sub 'Eğer hücre değeri silinirse makro çalışmaz
If Not Intersect(Target, Range("c:c")) Is Nothing Then numara_at

End Sub

Private Sub numara_at()

For X = 4 To 6500
If Cells(X, 3) > 0 And Cells(X, 1) = 0 Then
Cells(X, 1) = Cells(X - 1, 1) + 1
Cells(X, 2) = Cells(X - 1, 2) + 1
End If
Next

End Sub

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu kullanın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bak As Long
    Dim kBak As Long
    Application.EnableEvents = False
    If Not Intersect(Target, Range("c:c")) Is Nothing Then
        For kBak = 1 To Target.Count
            If Target(kBak).Value <> "" Then 'Eğer hücre değeri silinirse makro çalışmaz
                For Bak = 4 To Cells(Rows.Count, "C").End(xlUp).Row
                    If Cells(Bak, "C") > 0 And Cells(Bak, "A") = 0 Then
                        Cells(Bak, "A") = Cells(Bak - 1, "A") + 1
                        Cells(Bak, "B") = Cells(Bak - 1, "B") + 1
                    End If
                Next
            End If
        Next
    End If
    Application.EnableEvents = True
End Sub

 

[ndako]

Merhaba.

Aşağıdaki kodu kullanın.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bak As Long
    Dim kBak As Long
    Application.EnableEvents = False
    If Not Intersect(Target, Range("c:c")) Is Nothing Then
        For kBak = 1 To Target.Count
            If Target(kBak).Value <> "" Then 'Eğer hücre değeri silinirse makro çalışmaz
       
            For Bak = 4 To Cells(Rows.Count, "C").End(xlUp).Row
           
                If Cells(Bak, "C") > 0 And Cells(Bak, "A") = 0 Then
                    Cells(Bak, "A") = Cells(Bak - 1, "A") + 1
                    Cells(Bak, "B") = Cells(Bak - 1, "B") + 1
                End If
            Next
            End If
        Next
    End If
    Application.EnableEvents = True
End Sub

Hocam çok teşekkür ederim mükemmel çalışıyor.