makro ve formül

[gedavet]

HEM MAKRO DEĞİŞECEK
HEMDE
İSİM ÇIKAN SÜTUNDAKİ FORMÜL DEĞİŞECEK
makro var bu makro alındı belgesine kayıt yapılmayan numaraları yazdırmıyor ve daha önce aylara kayıt yapıldı ise onuda yazdırmıyor
yanlız D5 hücresine bir sayı yazılıyor mesela 851 bu şkilde yazılınca e6 da isim geliyor işlem tamam
ancak satır yetmediği için aynı tarihde ki numaraları mesela 851-900 arası aynı tarih olduğu için toplu yazmıyor makrodaki ve formüldeki değişikliği yapı veren varmı

 

[gedavet]

arkadaşlar yardımcı oacak yokmu

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim SAYFA As Worksheet, SA As Worksheet
    Dim SAY1 As Integer, SAY2 As Integer, SAY3 As Integer, SAY4 As Integer, X As Integer, BUL As Range
    Dim AYIR1 As Variant, AYIR2 As Variant
    
    Set SA = Sheets("ALINDI BELGESİ")
    If Intersect(Target, [D6:D505]) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If ActiveSheet.Tab.ColorIndex <> 4 Then Exit Sub
        
    ActiveSheet.Unprotect Password:=("313")
    If Target = Empty Then Target.Offset(0, 1).ClearContents
    If Target <> "" And IsNumeric(Target) Then
    For X = 5 To SA.[C65536].End(3).Row
    If Target >= SA.Cells(X, 3) And Target <= SA.Cells(X, 4) And SA.Cells(X, 6) <> "" Then
    Application.EnableEvents = False
    Target.Offset(0, 1).Value = SA.Cells(X, "F").Value
    Application.EnableEvents = True
    SAY1 = SAY1 + 1
    Exit For
    End If
    Next
    
    If SAY1 = 0 Then
    MsgBox "BU NUMARALI MAKBUZ ALINDI BELGES&#304;NE KAYIT ED&#304;LMEM&#304;&#350;T&#304;R" & Chr(10) & "L&#220;TFEN KAYIT ED&#304;N&#304;Z", vbCritical, "D&#304;KKAT !!!!!       HATALI G&#304;R&#304;&#350; YAPTINIZ"
    Application.EnableEvents = False
    Target.Offset(0, 1).ClearContents
    Target.ClearContents
    Target.Select
    Application.EnableEvents = True
    GoTo Son
    End If
    
    For Each SAYFA In Worksheets
    If SAYFA.Tab.ColorIndex = 4 Then
    SAY2 = SAY2 + WorksheetFunction.CountIf(SAYFA.[D6:D505], Target)
    For Each H&#220;CRE In SAYFA.[D6:D505]
    If H&#220;CRE.Value <> "" And InStr(1, H&#220;CRE.Value, "-") > 0 Then
    AYIR1 = Split(H&#220;CRE.Value, "-")
    For X = Val(AYIR1(0)) To Val(AYIR1(1))
    If X = Target Then
    SAY2 = SAY2 + 1
    Exit For
    End If
    Next
    End If
    Next
    End If
    Next
    
    If SAY2 > 1 Then
    MsgBox "BU NUMARALI MAKBUZ DAHA &#214;NCE KAYIT ED&#304;LM&#304;&#350;T&#304;R" & Chr(10) & "L&#220;TFEN KONTROL ED&#304;N&#304;Z", vbCritical, "D&#304;KKAT !!!!!       HATALI G&#304;R&#304;&#350; YAPTINIZ"
    Application.EnableEvents = False
    Target.Offset(0, 1).ClearContents
    Target.ClearContents
    Target.Select
    Application.EnableEvents = True
    GoTo Son
    ElseIf InStr(1, Target, "-") > 0 Then
    AYIR1 = Split(Target, "-")
    Set BUL = SA.Range("D5:D" & SA.[D65536].End(3).Row).Find(Val(AYIR1(1)))
    If Not BUL Is Nothing Then
    Application.EnableEvents = False
    SA.Cells(BUL.Row, "L") = "TAMAMI B&#304;TM&#304;&#350;T&#304;R"
    Application.EnableEvents = True
    GoTo Son
    End If
    ElseIf InStr(1, Target, "-") = 0 Then
    Set BUL = SA.Range("D5:D" & SA.[D65536].End(3).Row).Find(Target)
    If Not BUL Is Nothing Then
    Application.EnableEvents = False
    SA.Cells(BUL.Row, "L") = "TAMAMI B&#304;TM&#304;&#350;T&#304;R"
    Application.EnableEvents = True
    GoTo Son
    End If
    End If
    End If
    
    
    If Target <> "" And InStr(1, Target, "-") > 0 Then
    AYIR1 = Split(Target, "-")
    For X = 5 To SA.[C65536].End(3).Row
    If Val(AYIR1(0)) >= SA.Cells(X, 3) And Val(AYIR1(1)) <= SA.Cells(X, 4) And SA.Cells(X, 6) <> "" Then
    Application.EnableEvents = False
    Target.Offset(0, 1).Value = SA.Cells(X, "F").Value
    Application.EnableEvents = True
    SAY3 = SAY3 + 1
    Exit For
    End If
    Next
    
    If SAY3 = 0 Then
    MsgBox "BU NUMARALI MAKBUZ ALINDI BELGES&#304;NE KAYIT ED&#304;LMEM&#304;&#350;T&#304;R" & Chr(10) & "L&#220;TFEN KAYIT ED&#304;N&#304;Z", vbCritical, "D&#304;KKAT !!!!!       HATALI G&#304;R&#304;&#350; YAPTINIZ"
    Application.EnableEvents = False
    Target.Offset(0, 1).ClearContents
    Target.ClearContents
    Target.Select
    Application.EnableEvents = True
    GoTo Son
    End If
    
    For Each SAYFA In Worksheets
    If SAYFA.Tab.ColorIndex = 4 Then
    SAY4 = SAY4 + WorksheetFunction.CountIf(SAYFA.[D6:D505], Target)
    For Each H&#220;CRE In SAYFA.[D6:D505]
    If H&#220;CRE.Value <> "" And InStr(1, H&#220;CRE.Value, "-") > 0 Then
    If H&#220;CRE.Value <> Target Then
    AYIR2 = Split(H&#220;CRE.Value, "-")
    If Val(AYIR1(0)) >= Val(AYIR2(0)) And Val(AYIR1(1)) <= Val(AYIR2(1)) Or WorksheetFunction.CountIf(SAYFA.[D6:D505], Val(AYIR1(0))) Then
    SAY4 = SAY4 + 1
    Exit For
    End If
    End If
    End If
    Next
    End If
    Next
    
    If SAY4 > 1 Then
    MsgBox "BU NUMARALI MAKBUZ DAHA &#214;NCE KAYIT ED&#304;LM&#304;&#350;T&#304;R" & Chr(10) & "L&#220;TFEN KONTROL ED&#304;N&#304;Z", vbCritical, "D&#304;KKAT !!!!!       HATALI G&#304;R&#304;&#350; YAPTINIZ"
    Application.EnableEvents = False
    Target.Offset(0, 1).ClearContents
    Target.ClearContents
    Target.Select
    Application.EnableEvents = True
    ElseIf InStr(1, Target, "-") > 0 Then
    AYIR2 = Split(Target, "-")
    Set BUL = SA.Range("D5:D" & SA.[D65536].End(3).Row).Find(Val(AYIR2(1)))
    If Not BUL Is Nothing Then
    Application.EnableEvents = False
    SA.Cells(BUL.Row, "L") = "TAMAMI B&#304;TM&#304;&#350;T&#304;R"
    Application.EnableEvents = True
    GoTo Son
    End If
    ElseIf InStr(1, Target, "-") = 0 Then
    Set BUL = SA.Range("D5:D" & SA.[D65536].End(3).Row).Find(Target)
    If Not BUL Is Nothing Then
    Application.EnableEvents = False
    SA.Cells(BUL.Row, "L") = "TAMAMI B&#304;TM&#304;&#350;T&#304;R"
    Application.EnableEvents = True
    GoTo Son
    End If
    End If
    End If
    
Son: ActiveSheet.Protect Password:=("313"), DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
     ActiveSheet.EnableSelection = xlUnlockedCells
End Sub