• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

koşullu makro çalıştırma

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Sayfa1 in C:C sinde "Etkin" yazıyorsa makro çalışsın yazmıyorsa makro çalışmasın bu konuda yardımcı olurmusunuz üstatlar Saygılar
 
Merhaba
Aşağıdaki gibi olabilir
Kod: 
Sub Makro1()
If Sheets("Sayfa1").[C:C].Find("etkin", , xlFormulas, xlPart, xlByRows, xlNext, False, False) Is Nothing Then Exit Sub
'....
'......diğer kodlar
'...
end sub
 
PLİNT' Alıntı:
Merhaba
Aşağıdaki gibi olabilir
Kod: 
Sub Makro1()
If Sheets("Sayfa1").[C:C].Find("etkin", , xlFormulas, xlPart, xlByRows, xlNext, False, False) Is Nothing Then Exit Sub
'....
'......diğer kodlar
'...
end sub
Genişletmek için tıkla ...
Sayın plint
End if eksik sanırım onu ekledim yine hata verdi
 
Merhaba
Eksik değlide yukarıdaki şekilde gerek yok, siz kodlarınızı ekleyebilirmisiniz?
Ek dosyadaki gibi;

Downloads - TRtransfer

- deneme.zip - TRtransfer
trtransfer.net trtransfer.net
 
Son düzenleme:
PLİNT' Alıntı:
Merhaba
Eksik değlide yukarıdaki şekilde gerek yok, siz kodlarınızı ekleyebilirmisiniz?
Genişletmek için tıkla ...
sayın plint ANA SAYFA nın C:C sütununda "Etkin" yazıyorsa makro çalışsın yazmıyorsa başka kodu ekleyeceğim ben altına onu çalıştıracağım

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [D2]) Is Nothing Then Exit Sub

Dim Bul As Range, _
adr As String, _
sat As Long, _
sv As Worksheet

Set sv = Sheets("ANA SAYFA")

Set sb = Sheets("PERSONEL ZIMMET FORMU")
sb.Range("B13") = Date

Application.ScreenUpdating = False


With sv.Range("B:B")

Set Bul = .Find(Target.Value, LookIn:=xlValues, LookAt:=xlPart)

If Not Bul Is Nothing Then

adr = Bul.Address

Do


If sv.Cells(Bul.Row, "B:B") = Cells(2, 4) Then




Cells(3, 4) = sv.Cells(Bul.Row, "D") 'ADI SOYADI

Cells(4, 4) = sv.Cells(Bul.Row, "E")

Cells(5, 4) = sv.Cells(Bul.Row, "F")

Cells(6, 4) = sv.Cells(Bul.Row, "G")

Cells(7, 3) = sv.Cells(Bul.Row, "I")

Cells(7, 5) = sv.Cells(Bul.Row, "M")

Cells(8, 3) = sv.Cells(Bul.Row, "J")

Cells(8, 5) = sv.Cells(Bul.Row, "N")

Cells(9, 3) = sv.Cells(Bul.Row, "K")

Cells(9, 5) = sv.Cells(Bul.Row, "O")

Cells(10, 3) = sv.Cells(Bul.Row, "L")

Cells(10, 5) = sv.Cells(Bul.Row, "P")

End If


Loop While Not Bul Is Nothing And Bul.Address <> adr
End If


End With

Application.ScreenUpdating = True

End Sub
 
Merhaba
Aşağıdaki kodları deneyiniz
"Anasayfa" adlı sayfanın [B:B] sütununda;"D2" hücresine yazılan (diyelimki) sicili arayacak aşağıda işaretli kodlar ile bulunan sicilin "C" satırında "etkin" yazıyorsa işlem yapmayacak.
(Böyle ise döngülü arama yapmaya gerekde yok )
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D2]) Is Nothing Then Exit Sub
Dim Bul As Range, _
adr As String, _
sat As Long, _
sv As Worksheet
Set sv = Sheets("ANA SAYFA")
Set sb = Sheets("PERSONEL ZIMMET FORMU")
sb.Range("B13") = Date
Application.ScreenUpdating = False
With sv.Range("B:B")
Set Bul = .Find(Target.Value, LookIn:=xlValues, LookAt:=xlPart)
If Not Bul Is Nothing Then
adr = Bul.Address
Do
If sv.Cells(Bul.Row, "B") = Cells(2, 4) Then
'------------------------------
If sv.Cells(Bul.Row, "C") = "Etkin" Then
MsgBox sv.Cells(Bul.Row, "D") & " Adlı kişi Etkin" & vbCrLf & "İşlem yapılmayacak"
Else
'------------------------------------
Cells(3, 4) = sv.Cells(Bul.Row, "D") 'ADI SOYADI
Cells(4, 4) = sv.Cells(Bul.Row, "E")
Cells(5, 4) = sv.Cells(Bul.Row, "F")
Cells(6, 4) = sv.Cells(Bul.Row, "G")
Cells(7, 3) = sv.Cells(Bul.Row, "I")
Cells(7, 5) = sv.Cells(Bul.Row, "M")
Cells(8, 3) = sv.Cells(Bul.Row, "J")
Cells(8, 5) = sv.Cells(Bul.Row, "N")
Cells(9, 3) = sv.Cells(Bul.Row, "K")
Cells(9, 5) = sv.Cells(Bul.Row, "O")
Cells(10, 3) = sv.Cells(Bul.Row, "L")
Cells(10, 5) = sv.Cells(Bul.Row, "P")
End If '<------------------
End If
Loop While Not Bul Is Nothing And Bul.Address <> adr
End If
End With
Application.ScreenUpdating = True
End Sub
 
PLİNT' Alıntı:
Merhaba
Aşağıdaki kodları deneyiniz
"Anasayfa" adlı sayfanın [B:B] sütununda;"D2" hücresine yazılan (diyelimki) sicili arayacak aşağıda işaretli kodlar ile bulunan sicilin "C" satırında "etkin" yazıyorsa işlem yapmayacak.
(Böyle ise döngülü arama yapmaya gerekde yok )
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D2]) Is Nothing Then Exit Sub
Dim Bul As Range, _
adr As String, _
sat As Long, _
sv As Worksheet
Set sv = Sheets("ANA SAYFA")
Set sb = Sheets("PERSONEL ZIMMET FORMU")
sb.Range("B13") = Date
Application.ScreenUpdating = False
With sv.Range("B:B")
Set Bul = .Find(Target.Value, LookIn:=xlValues, LookAt:=xlPart)
If Not Bul Is Nothing Then
adr = Bul.Address
Do
If sv.Cells(Bul.Row, "B") = Cells(2, 4) Then
'------------------------------
If sv.Cells(Bul.Row, "C") = "Etkin" Then
MsgBox sv.Cells(Bul.Row, "D") & " Adlı kişi Etkin" & vbCrLf & "İşlem yapılmayacak"
Else
'------------------------------------
Cells(3, 4) = sv.Cells(Bul.Row, "D") 'ADI SOYADI
Cells(4, 4) = sv.Cells(Bul.Row, "E")
Cells(5, 4) = sv.Cells(Bul.Row, "F")
Cells(6, 4) = sv.Cells(Bul.Row, "G")
Cells(7, 3) = sv.Cells(Bul.Row, "I")
Cells(7, 5) = sv.Cells(Bul.Row, "M")
Cells(8, 3) = sv.Cells(Bul.Row, "J")
Cells(8, 5) = sv.Cells(Bul.Row, "N")
Cells(9, 3) = sv.Cells(Bul.Row, "K")
Cells(9, 5) = sv.Cells(Bul.Row, "O")
Cells(10, 3) = sv.Cells(Bul.Row, "L")
Cells(10, 5) = sv.Cells(Bul.Row, "P")
End If '<------------------
End If
Loop While Not Bul Is Nothing And Bul.Address <> adr
End If
End With
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Sayın print hocam tam tersi olacak "Etkin" yazıyorsa bu kod çalışacak "İşten Ayrıldı" yazıyorsa ben bu kodun altına başka bir kod daha ekleyeceğim o kotu çalıştıracak
 
Merhaba
Evet ben karıştırdım
Kodlarda ilk işaretli kısımda; bakacak "etkin" kelimesi varsa çalıştıracak yoksa; ikinci işaretli kısımda mesaj verip "yenimakro" kodları çalışacak
siz düzenlersiniz

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D2]) Is Nothing Then Exit Sub
Dim Bul As Range, _
adr As String, _
sat As Long, _
sv As Worksheet
Set sv = Sheets("ANA SAYFA")
Set sb = Sheets("PERSONEL ZIMMET FORMU")
sb.Range("B13") = Date
Application.ScreenUpdating = False
With sv.Range("B:B")
Set Bul = .Find(Target.Value, LookIn:=xlValues, LookAt:=xlPart)
If Not Bul Is Nothing Then
adr = Bul.Address
Do
If sv.Cells(Bul.Row, "B") = Cells(2, 4) Then
'------------------------------
If sv.Cells(Bul.Row, "C") = "Etkin" Then
'------------------------------------
Cells(3, 4) = sv.Cells(Bul.Row, "D") 'ADI SOYADI
Cells(4, 4) = sv.Cells(Bul.Row, "E")
Cells(5, 4) = sv.Cells(Bul.Row, "F")
Cells(6, 4) = sv.Cells(Bul.Row, "G")
Cells(7, 3) = sv.Cells(Bul.Row, "I")
Cells(7, 5) = sv.Cells(Bul.Row, "M")
Cells(8, 3) = sv.Cells(Bul.Row, "J")
Cells(8, 5) = sv.Cells(Bul.Row, "N")
Cells(9, 3) = sv.Cells(Bul.Row, "K")
Cells(9, 5) = sv.Cells(Bul.Row, "O")
Cells(10, 3) = sv.Cells(Bul.Row, "L")
Cells(10, 5) = sv.Cells(Bul.Row, "P")
'------------------------------------
Else
MsgBox sv.Cells(Bul.Row, "D") & " İşten Ayrıldı" & vbCrLf & "yenimakro çalışacak"
Call yenimakro
End If
'------------------------------------
End If
Loop While Not Bul Is Nothing And Bul.Address <> adr
End If
End With
Application.ScreenUpdating = True
End Sub

Sub yenimakro()
MsgBox "Merhaba"
End Sub
"İşten Ayrıldı" ve "etkin" sözcüklerinden başka bir kelime olma ihtimaline karşı
İşaretli bölümler aşağıdaki gibide düzenlenebilir
Kod: 
'------------------------------
If sv.Cells(Bul.Row, "C") = "Etkin" Then
'------------------------------------
Cells(3, 4) = sv.Cells(Bul.Row, "D") 'ADI SOYADI
Cells(4, 4) = sv.Cells(Bul.Row, "E")
Cells(5, 4) = sv.Cells(Bul.Row, "F")
Cells(6, 4) = sv.Cells(Bul.Row, "G")
Cells(7, 3) = sv.Cells(Bul.Row, "I")
Cells(7, 5) = sv.Cells(Bul.Row, "M")
Cells(8, 3) = sv.Cells(Bul.Row, "J")
Cells(8, 5) = sv.Cells(Bul.Row, "N")
Cells(9, 3) = sv.Cells(Bul.Row, "K")
Cells(9, 5) = sv.Cells(Bul.Row, "O")
Cells(10, 3) = sv.Cells(Bul.Row, "L")
Cells(10, 5) = sv.Cells(Bul.Row, "P")
'------------------------------------
End If
If sv.Cells(Bul.Row, "C") = "İşten Ayrıldı" Then Call yenimakro
'------------------------------------
 
Son düzenleme:
PLİNT' Alıntı:
Merhaba
Evet ben karıştırdım
Kodlarda ilk işaretli kısımda; bakacak "etkin" kelimesi varsa çalıştıracak yoksa; ikinci işaretli kısımda mesaj verip "yenimakro" kodları çalışacak
siz düzenlersiniz

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D2]) Is Nothing Then Exit Sub
Dim Bul As Range, _
adr As String, _
sat As Long, _
sv As Worksheet
Set sv = Sheets("ANA SAYFA")
Set sb = Sheets("PERSONEL ZIMMET FORMU")
sb.Range("B13") = Date
Application.ScreenUpdating = False
With sv.Range("B:B")
Set Bul = .Find(Target.Value, LookIn:=xlValues, LookAt:=xlPart)
If Not Bul Is Nothing Then
adr = Bul.Address
Do
If sv.Cells(Bul.Row, "B") = Cells(2, 4) Then
'------------------------------
If sv.Cells(Bul.Row, "C") = "Etkin" Then
'------------------------------------
Cells(3, 4) = sv.Cells(Bul.Row, "D") 'ADI SOYADI
Cells(4, 4) = sv.Cells(Bul.Row, "E")
Cells(5, 4) = sv.Cells(Bul.Row, "F")
Cells(6, 4) = sv.Cells(Bul.Row, "G")
Cells(7, 3) = sv.Cells(Bul.Row, "I")
Cells(7, 5) = sv.Cells(Bul.Row, "M")
Cells(8, 3) = sv.Cells(Bul.Row, "J")
Cells(8, 5) = sv.Cells(Bul.Row, "N")
Cells(9, 3) = sv.Cells(Bul.Row, "K")
Cells(9, 5) = sv.Cells(Bul.Row, "O")
Cells(10, 3) = sv.Cells(Bul.Row, "L")
Cells(10, 5) = sv.Cells(Bul.Row, "P")
'------------------------------------
Else
MsgBox sv.Cells(Bul.Row, "D") & " İşten Ayrıldı" & vbCrLf & "yenimakro çalışacak"
Call yenimakro
End If
'------------------------------------
End If
Loop While Not Bul Is Nothing And Bul.Address <> adr
End If
End With
Application.ScreenUpdating = True
End Sub

Sub yenimakro()
MsgBox "Merhaba"
End Sub
"İşten Ayrıldı" ve "etkin" sözcüklerinden başka bir kelime olma ihtimaline karşı
İşaretli bölümler aşağıdaki gibide düzenlenebilir
Kod: 
'------------------------------
If sv.Cells(Bul.Row, "C") = "Etkin" Then
'------------------------------------
Cells(3, 4) = sv.Cells(Bul.Row, "D") 'ADI SOYADI
Cells(4, 4) = sv.Cells(Bul.Row, "E")
Cells(5, 4) = sv.Cells(Bul.Row, "F")
Cells(6, 4) = sv.Cells(Bul.Row, "G")
Cells(7, 3) = sv.Cells(Bul.Row, "I")
Cells(7, 5) = sv.Cells(Bul.Row, "M")
Cells(8, 3) = sv.Cells(Bul.Row, "J")
Cells(8, 5) = sv.Cells(Bul.Row, "N")
Cells(9, 3) = sv.Cells(Bul.Row, "K")
Cells(9, 5) = sv.Cells(Bul.Row, "O")
Cells(10, 3) = sv.Cells(Bul.Row, "L")
Cells(10, 5) = sv.Cells(Bul.Row, "P")
'------------------------------------
End If
If sv.Cells(Bul.Row, "C") = "İşten Ayrıldı" Then Call yenimakro
'------------------------------------
Genişletmek için tıkla ...
çok teşekkür ederim Plint hocam kodları uyarladım kendime gayet güzel çalışıyor Hayırlı geceler
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst