Excel Vba Forum - Excelce.Net
SORU ve CEVAPLAR (Yazılabilir) => Microsoft Excel, Vba, Makro, Formül vb. Soruları => Çözülen Excel, Vba, Makro, Formül vb. Soruları => Konuyu başlatan: Hüseyin Çoban - 14 Kasım 2010, 17:08:21
-
Merhaba Arkadaşlar,
Veri yönetimi sayfasında B sütununa 5. satırdan itibaren tarihler girdiğimde
A sütununda ilgili satırlara sıra no vermesini sağlayabilirmiyiz.
Formül ile yapılabilecek bir işlem ancak, formülü aşağı satırlara doğru uygulattıkça tablo boyutu çok yükseliyor. Tam kaç satıra uygulatmam gerektiğide belli değil.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B6:B65536")) Is Nothing Then Exit Sub
If Target <> "" Then
Cells(Target.Row, "A") = WorksheetFunction.Max(Range("A5:A" & Target.Row - 1)) + 1
Else
Cells(Target.Row, "A") = ""
End If
End Sub
işlemi bu kodlar ile çözmeye çalıştım ancak, tabloya uyarlamada sorun yaşadım. Tabloda düşeyara ve çarpma makrolarıda var.
Yardım ve fikirlerinizi bekliyorum.
[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]
-
Merhaba
Kodlarınızı aşağıdaki gibi deneyin.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B6:B65536")) Is Nothing Then GoTo ff
If Target <> "" Then
Cells(Target.Row, "A") = WorksheetFunction.Max(Range("A5:A" & Target.Row - 1)) + 1
Else
Cells(Target.Row, "A") = ""
End If
ff:
If Not Intersect(Target, Range("E6:E65536")) Is Nothing Then
On Error Resume Next
If Target = "" Then Exit Sub
If WorksheetFunction.CountIf(Sheets("hesap planı").Range("B:B"), Cells(Target.Row, "E")) > 0 Then
Cells(Target.Row, "F") = WorksheetFunction.VLookup(Cells(Target.Row, "E"), Sheets("hesap planı").Range("B:c"), 2, 0)
Else
End If
If WorksheetFunction.CountIf(Sheets("hesap planı").Range("B:B"), Cells(Target.Row, "E")) > 0 Then
Cells(Target.Row, "G") = WorksheetFunction.VLookup(Cells(Target.Row, "E"), Sheets("hesap planı").Range("B:D"), 3, 0)
Else
'Cells(Target.Row, "E") = ""
MsgBox " Girdiğiniz Hesap Kodu Hesap Planında Bulunamadı !", vbCritical
End If
End If
If Intersect(Target, Range("D6:D65536,H6:I65536")) Is Nothing Then Exit Sub
If UCase(Cells(Target.Row, "D")) = "B" Then
Cells(Target.Row, "J") = Cells(Target.Row, "H") * Cells(Target.Row, "I")
Cells(Target.Row, "K").ClearContents
ElseIf UCase(Cells(Target.Row, "D")) = "A" Then
Cells(Target.Row, "K") = Cells(Target.Row, "H") * Cells(Target.Row, "I")
Cells(Target.Row, "J").ClearContents
Else
MsgBox "Lütfen kayıt türü bilgisini giriniz !", vbCritical
End If
End Sub
-
Sy Rami, çok teşekkürkler. Tam istediğim gibi olmuş sorunsuz çalışıyor. :alkis
Emeğinize sağlık. :yihu