Aynı sayfada 2 makronun çalışması

[82_elbistan]

1. MAKRO

Private Sub Worksheet_change(ByVal Target As Range)
Dim RaBereich As Range, RaZelle As Range
Application.EnableEvents = False
Set RaBereich = Range("B3:C3")
Application.EnableEvents = False
For Each RaZelle In Range(Target.Address)
If Not Intersect(RaZelle, RaBereich) Is Nothing Then
RaZelle.Value = UCase(RaZelle.Value)
End If
Next RaZelle
Application.EnableEvents = True
Set RaBereich = Nothing
Dim hucre As Range, say As Long
Dim sut_adr As String, sat_adr As String
On Error GoTo hata
If Intersect(Target, [B:C]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
sut_adr = Range(Cells(1, Target.Column), Cells(Cells(65536, Target.Column).End(xlUp).Row, Target.Column)).Address
sat_adr = Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Address
For Each hucre In Range(sut_adr)
If hucre.Value = Target.Value Then say = say + 1
If say >= 2 Then
MsgBox "GİRDİĞİNİZ CARİ KAYITLIDIR..." & _
vbLf & "", vbCritical, "Mükerrer Kayıt Hatası"
Target.Value = Empty
Cancel = True
Exit Sub
End If
Next
For Each hucre In Range(sat_adr)
If hucre.Value = Target.Value Then say = say + 1
If say >= 3 Then
MsgBox " GİRDİĞİNİZ CARİ KAYITLIDIR..." & _
vbLf & "", vbCritical, "Mükerrer Kayıt Hatası"
Target.Value = Empty
Cancel = True
Exit Sub
End If
Next
hata:
End Sub

2. MAKRO

Private Sub Worksheet_Deactivate()
Range("B5:I" & Rows.Count).Sort Range("B5"), xlAscending
End Sub


Arkadaşlar bu iki makroyu aynı sayfada nasıl çalıştırabilirim. Yardım lütfen

 

[metehan8001]

Aşağıdaki kodu MAKRO1'deki hata: kod satırının üstüne ekleyin.

Range("B5:I" & Rows.Count).Sort Range("B5"), xlAscending

 

[82_elbistan]

Çok teşekkür ederim üstat sağol

 

[82_elbistan]

Arkadaşlar bu iki makroyu aynı sayfada nasıl çalıştırabilirim. Yardım lütfen

1-MAKRO
Private Sub Worksheet_change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
'................
If Intersect(Target, Range("C3")) Is Nothing Then GoTo 10
'........................
If Not UserForm1.ListBox1.Tag = "off" Then
Dim deger As Range
sayac = 0
derlenen = Target.Address
bakilan = UCase(Replace(Replace(Target.Value, "i", "İ"), "ı", "I"))
For Each deger In Sheets("MÜŞTERİ").Range("C5:C2000")

If Not IsEmpty(deger.Value) And Left(deger.Value, Len(bakilan)) = bakilan Then

sayac = sayac + 1
sonuc = deger.Value

If sayac = 1 Then
UserForm1.ListBox1.Clear
End If

UserForm1.ListBox1.AddItem deger.Value

End If

Next


If sayac > 1 Then
UserForm1.Tag = derlenen
UserForm1.Caption = "LÜTFEN CARİ SEÇİMİNİ YAPINIZ"
UserForm1.ListBox1.Tag = "off"

UserForm1.Show

UserForm1.ListBox1.Tag = ""

ElseIf sayac = 1 Then
UserForm1.ListBox1.Tag = "off"
Range(derlenen) = sonuc
Else

UserForm1.ListBox1.Tag = "off"
bakilan = ""
sayac = 0
For Each deger In Sheets("MÜŞTERİ").Range("C5:C2000")

If Not IsEmpty(deger.Value) And Left(deger.Value, Len(bakilan)) = bakilan Then

sayac = sayac + 1
sonuc = deger.Value

If sayac = 1 Then
UserForm1.ListBox1.Clear
End If

UserForm1.ListBox1.AddItem deger.Value

End If

Next
UserForm1.Tag = derlenen
UserForm1.Caption = "UYGUN BİR CARİ BULUNAMADI...! LÜTFEN CARİ KAYDI YAPINIZ"
Range(derlenen) = ""

UserForm1.Show
End If
Else
UserForm1.ListBox1.Tag = ""
End If

'......................................
10:
If Intersect(Target, Range("F3")) Is Nothing Then Exit Sub
If Trim(Target.Value) <> "" And IsNumeric(Target.Value) = True Then Call Müşteri_Kayıt
'...........................
End Sub



2. MAKRO
Private Sub Worksheet_change(ByVal Target As Range)
Dim RaBereich As Range, RaZelle As Range
Application.EnableEvents = False
Set RaBereich = Range("B3:B3")
Application.EnableEvents = False
For Each RaZelle In Range(Target.Address)
If Not Intersect(RaZelle, RaBereich) Is Nothing Then
RaZelle.Value = UCase(RaZelle.Value)
End If
Next RaZelle
Application.EnableEvents = True
Set RaBereich = Nothing
Dim hucre As Range, say As Long
Dim sut_adr As String, sat_adr As String
On Error GoTo hata
Range("B5:I" & Rows.Count).Sort Range("B5"), xlAscending
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
sut_adr = Range(Cells(1, Target.Column), Cells(Cells(65536, Target.Column).End(xlUp).Row, Target.Column)).Address
sat_adr = Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Address
For Each hucre In Range(sut_adr)
If hucre.Value = Target.Value Then say = say + 1
If say >= 2 Then
MsgBox "GİRDİĞİNİZ CARİ KAYITLIDIR..." & _
vbLf & "", vbCritical, "Mükerrer Kayıt Hatası"
Target.Value = Empty
Cancel = True
Exit Sub
End If
Next
For Each hucre In Range(sat_adr)
If hucre.Value = Target.Value Then say = say + 1
If say >= 3 Then
MsgBox " GİRDİĞİNİZ CARİ KAYITLIDIR..." & _
vbLf & "", vbCritical, "Mükerrer Kayıt Hatası"
Target.Value = Empty
Cancel = True
Exit Sub
End If
Next
hata:
End Sub