• DİKKAT

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

Ara bul işlem yap

M

mesutaygun70

Katılım
27 Şubat 2008
Mesajlar
307
Excel Vers. ve Dili
Office 2016
İşlem sayfası a1:a4000 içerisinde(FORMÜL İÇERİYOR (FORMÜLLÜ OLDUĞU İÇİN CTRL+ F ARAMA SONUCU BULAMIYOR) Veri a1 hücresini ara
yoksa(msgbox: "KAYITLI KİŞİ BULUNAMIYOR KONTROL EDİNİZ";
varsa (bulunduğu satırı, kayıt sayfası a satırına yapıştır."
kayıt a5=eksik ise msgbox :"tarama yap"
işlem tamamdan = tarama sayfasından 1 adet yazdır.
kayıt a6=eski tarih ise msgbox :tarama yap
işlem tamamdan tarama1 sayfasından 1 adet yazdır.
kayıt a5 ve a6 ="" ise msg box taramalar günceldir.
 
Merhaba,

Sorunuzu anlayamadım. Sorunuzu destekleyen örnek dosya ekleyip, dosya içerisinde detaylı açıklama yapmanızı rica ederim.

.
 
Yapmak istediğiniz işlemi biraz daha açıklayabilir misiniz.
 
işlem sayfası b2 ye tc kimlik no yazacağım
tc yi veri sayfası b:b sütunuda arayacak bulamassa yok uyarısı verecek
bulursa bulduğu satırı (örnektekine göre 3958. satırı kopyalayarak - kayıt sayfası 1. satıra yapıştıracak (özel yapıştırdan değerleri şeklinde olması daha iyi olur.)
bu yapıştırma işleminden sonra
kayıt sayfası a5 eksik ise 1 tane gaita form sayfasından çıktı alacak (eğer a5<>eksik değeri haricinde birşeyse herhangi bir işlem yapmayacak
 
Kayıt sayfası 1.satıra yapıştırınca Kayıt sayfası a5 deki veriye göre nasıl yazdıracak.Eksik dediğinin ne.
 
Sub Düğme2_Tıkla()
Dim DEG As String
On Error GoTo HATA
Range("b1:d10000").Interior.ColorIndex = xlNone
DEG = InputBox("Arama Yapılacak TC Kimlik Numarasınız Giriniz.")
Range("b1:b10000").Find(DEG, LookIn:=xlValues, lookat:=xlWhole).Select
Range(Selection, Selection.Offset(0, 2)).Interior.ColorIndex = 6
HATA:
ActiveCell.Offset(0, 0).Select
Selection.Copy
Sheets("İŞLEM").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("İŞLEM").Select
If InStr("D2", "İZLEM") Then
Sayfa1.PrintOut copies:=1
Else
If InStr("E2", "YAPILACAK") Then
Sayfa6.PrintOut copies:=1
Else
If InStr("F2", "YAPILACAK") Then
Sayfa9.PrintOut copies:=1
End If
End If
End If
End Sub


Kodu yukardaki gibi düzenledim. Fakat yazdırma işlemlerini yapamıyorum. Tüm veriler doğru acaba neyi yanlış yazdım.
 
Yazdığınız kod ile eklediğiniz örnek tutmuyor. D E F sütunlarında kelime aratıyorsunuz. Ama arattığınız hücreler boş olduğu için örneğinize göre yorum yapma imkanı yok.
 
Aşağıdaki şekilde deneyin.
Kod: 
Private Sub CommandButton1_Click()
Dim DEG As String
Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("İŞLEM")
Set s2 = Sheets("VERİ")
s2.Select
On Error GoTo HATA

s2.Range("b1:d10000").Interior.ColorIndex = xlNone
DEG = InputBox("Arama Yapılacak TC Kimlik Numarasınız Giriniz.")
s2.Range("b1:b10000").Find(DEG, LookIn:=xlValues, lookat:=xlWhole).Select
s2.Range(Selection, Selection.Offset(0, 2)).Interior.ColorIndex = 6
HATA:
ActiveCell.Offset(0, 0).Select
Selection.Copy
s1.Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("İŞLEM").Select
If InStr(Range("D2"), "İZLEM") Then
Sayfa1.PrintOut copies:=1
Else
If InStr(Range("E2"), "YAPILACAK") Then
Sayfa6.PrintOut copies:=1
Else
If InStr(Range("F2"), "YAPILACAK") Then
Sayfa9.PrintOut copies:=1
End If
End If
End If
End Sub
 
Ayrıca aşağıdaki 1 kod ile İŞLEM sayfasındaki formülleri iptal edip bulunan satırdan veri getirerek de çıktı alabilirsiniz.
2. kodda ise işlem sayfasına hiç gerek olmadan çıktı alabilirsiniz.
Kod: 
Private Sub CommandButton1_Click()
Dim DEG As String
Dim Satir As Long

Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("İŞLEM")
Set s2 = Sheets("VERİ")
s2.Select
On Error GoTo HATA

s2.Range("b1:d10000").Interior.ColorIndex = xlNone
DEG = InputBox("Arama Yapılacak TC Kimlik Numarasınız Giriniz.")
s2.Range("b1:b10000").Find(DEG, LookIn:=xlValues, lookat:=xlWhole).Select
s2.Range(Selection, Selection.Offset(0, 2)).Interior.ColorIndex = 6
HATA:
Satir = ActiveCell.Row
'ActiveCell.Offset(0, 0).Select
'Selection.Copy
's1.Select
'Range("A2").Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
':=False, Transpose:=False
s1.Range("A2") = s2.Cells(Satir, "B")
s1.Range("D2") = s2.Cells(Satir, "E")
s1.Range("E2") = s2.Cells(Satir, "F")
s1.Range("D2") = s2.Cells(Satir, "G")


Sheets("İŞLEM").Select
If InStr(Range("D2"), "İZLEM") Then
Sayfa1.PrintOut copies:=1
Else
If InStr(Range("E2"), "YAPILACAK") Then
Sayfa6.PrintOut copies:=1
Else
If InStr(Range("F2"), "YAPILACAK") Then
Sayfa9.PrintOut copies:=1
End If
End If
End If
End Sub
Kod: 
Private Sub CommandButton2_Click()
Dim DEG As String
Dim Satir As Long

Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("İŞLEM")
Set s2 = Sheets("VERİ")
s2.Select
On Error GoTo HATA

s2.Range("b1:d10000").Interior.ColorIndex = xlNone
DEG = InputBox("Arama Yapılacak TC Kimlik Numarasınız Giriniz.")
s2.Range("b1:b10000").Find(DEG, LookIn:=xlValues, lookat:=xlWhole).Select
s2.Range(Selection, Selection.Offset(0, 2)).Interior.ColorIndex = 6
HATA:
Satir = ActiveCell.Row
'ActiveCell.Offset(0, 0).Select
'Selection.Copy
's1.Select
'Range("A2").Select
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
':=False, Transpose:=False
s1.Range("A2") = s2.Cells(Satir, "B")

If InStr(s2.Cells(Satir, "E"), "İZLEM") Then
Sayfa1.PrintOut copies:=1
Else
If InStr(s2.Cells(Satir, "F"), "YAPILACAK") Then
Sayfa6.PrintOut copies:=1
Else
If InStr(s2.Cells(Satir, "G"), "YAPILACAK") Then
Sayfa9.PrintOut copies:=1
End If
End If
End If
End Sub
 
Altarnatif olsun
Tüm kodları iptal edip
Modüle bu kodu yapıştırın
Bir düğmeye atayın
Aranacak TC [İŞLEM!B2] Hücresine yazılacak.

Kod: 
Sub TC_NO_SORGULA()
Dim MSTF, ss
ss = 0
For MSTF = 2 To Sheets("VERİ").Cells(65536, "B").End(xlUp).Row
If Sheets("VERİ").Cells(MSTF, "B") = [İŞLEM!B2] Then
For Yan = 1 To 45
Sheets("İŞLEM").Cells(2, Yan) = Sheets("VERİ").Cells(MSTF, Yan)
Next
ss = ss + 1
End If
Next
If ss = 0 Then
MsgBox [İŞLEM!B2] & " TC No Bulunamamıştır.", vbInformation, "Mustafa MUTLU 0 533 740 45 49"
End If

If [İŞLEM!D2] = "İZLEM" Then
On Error Resume Next
Sheets("KAYIT").PrintOut From:=1, To:=1
End If
If [İŞLEM!E2] = "YAPILACAK" Then
On Error Resume Next
Sheets("GAİTA FORM").PrintOut From:=1, To:=1
End If
If [İŞLEM!F2] = "YAPILACAK" Then
On Error Resume Next
Sheets("SERVİKS FORM").PrintOut From:=1, To:=1
End If

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst