- Excel Versiyonu
- Excel 2016
- Excel Sürümü
- 64 Bit
- Excel Dili
- Türkçe
Arkadaşlar merhaba. Aşağıdaki kod ile aranan kelimeyi sekmeler içinde arayıp gerekli yerlere getiriyorum. Ben kod yazmayı bilmiyorum. Bu kodu internetten buldum. Bir modülde bulunan Bu kodda nasıl bir değişiklik yaparsam sonuc isimli sayfanın B1 hücresine (B1 hücresi B1:D2 aralığında birleştirilmiştir) yazdıktan sonra enter tuşuna basınca hemen çalışsın. Saygılar.
Sub ogrenci_ara()
On Error Resume Next
Dim x, y, Sayfa, a, satir, sutun, sonBulunanSatir As Integer
Dim no As String
Dim bilgiBulundu As Boolean
bilgiBulundu = False
no = 2000 'bilgilerin bulunduğu sayfa isimlerinin ilki, 2000 yılını ifade ediyor
satir = 5 'sonuç ekranında bilgilerin aktarılacağı ilk satır
'ekranın güncellemesini geçici olarak durdurur
'böylece hem işlemler daha hızlanır hem de ekranda oluşan sayfa geçişleri engellenmiş olur
Application.ScreenUpdating = False
'aşağıdaki satır sonuç sayfasındaki bulunmuş olan bilgileri siler
'Aralığı tablonuza göre değiştirmelisiniz.
'Kod A5:C1000 arasındaki hücreleri siler
Range("A5:J1000").ClearContents
Range("B1").Select
If Range("B1").Value = "" Then
Range("B1").Value = InputBox(prompt:="Lütfen Ad Soyad Giriniz...", _
Title:="Hatalı Giriş", Default:="buraya yazınız")
End If
'..sonuç b1 hücresine arama yapmak istediğimiz isim yazılacak
Cells.Find(What:=[B1], After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
For Sayfa = CInt(no) To CInt(no) + Sheets.Count - 2
'Aşağıdaki bölümde ilgili sayfaya gidilip, aramanın yapılacağı B sütununun ilk hücresi seçiliyor
Sheets(CStr(Sayfa)).Select
no = CStr(Sayfa)
Range("b1").Select
sonBulunanSatir = 1
y = 1
'Aşağıdaki bölümde ilgili sayfadaki B sütununda arama yapılıp, bulunan bilgiler aktarılıyor.
For a = 1 To 1000
bulundu = Cells.FindNext(After:=ActiveCell).Activate
'eğer bir bilgi bulunmadıysa sonraki sayfaya geçer
If bulundu <> True Then Exit For
x = ActiveCell.Column
y = ActiveCell.Row
'eğer arama işlemi başa dönerse döngüden çık diğer sayfaya geç
'yani kayıt bulunamadığında ya da son bilgi bulunup, arama başa döndüğünde
If (y <= sonBulunanSatir) Then Exit For
sonBulunanSatir = y
bilgiBulundu = True
'Bulunan bilgiler sonuç sayfasına aktarılıyor
'diğer sütunlardaki bilgiler de aynı şekilde yazılan kodlarla aktarılmalıdır.
'aşağıdaki kod üç bilgiyi aktarmaktadır
Sheets("sonuc").Cells(satir, 1) = Sheets(no).Cells(y, 1)
Sheets("sonuc").Cells(satir, 2) = Sheets(no).Cells(y, 2)
Sheets("sonuc").Cells(satir, 3) = Sheets(no).Cells(y, 3)
Sheets("sonuc").Cells(satir, 4) = Sheets(no).Cells(y, 4)
Sheets("sonuc").Cells(satir, 5) = Sheets(no).Cells(y, 5)
Sheets("sonuc").Cells(satir, 6) = Sheets(no).Cells(y, 6)
Sheets("sonuc").Cells(satir, 7) = Sheets(no).Cells(y, 7)
Sheets("sonuc").Cells(satir, 8) = Sheets(no).Cells(y, 8)
Sheets("sonuc").Cells(satir, 9) = Sheets(no).Cells(y, 9)
Sheets("sonuc").Cells(satir, 10) = Sheets(no).Cells(y, 10)
satir = satir + 1
Next a
Next Sayfa
Sheets("sonuc").Select
Range("b1").Select
Application.ScreenUpdating = True
If bilgiBulundu = False Then MsgBox Range("b1").Value + " Adında Öğrenci Bulunamadı!"
End Sub
Sub ogrenci_ara()
On Error Resume Next
Dim x, y, Sayfa, a, satir, sutun, sonBulunanSatir As Integer
Dim no As String
Dim bilgiBulundu As Boolean
bilgiBulundu = False
no = 2000 'bilgilerin bulunduğu sayfa isimlerinin ilki, 2000 yılını ifade ediyor
satir = 5 'sonuç ekranında bilgilerin aktarılacağı ilk satır
'ekranın güncellemesini geçici olarak durdurur
'böylece hem işlemler daha hızlanır hem de ekranda oluşan sayfa geçişleri engellenmiş olur
Application.ScreenUpdating = False
'aşağıdaki satır sonuç sayfasındaki bulunmuş olan bilgileri siler
'Aralığı tablonuza göre değiştirmelisiniz.
'Kod A5:C1000 arasındaki hücreleri siler
Range("A5:J1000").ClearContents
Range("B1").Select
If Range("B1").Value = "" Then
Range("B1").Value = InputBox(prompt:="Lütfen Ad Soyad Giriniz...", _
Title:="Hatalı Giriş", Default:="buraya yazınız")
End If
'..sonuç b1 hücresine arama yapmak istediğimiz isim yazılacak
Cells.Find(What:=[B1], After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
For Sayfa = CInt(no) To CInt(no) + Sheets.Count - 2
'Aşağıdaki bölümde ilgili sayfaya gidilip, aramanın yapılacağı B sütununun ilk hücresi seçiliyor
Sheets(CStr(Sayfa)).Select
no = CStr(Sayfa)
Range("b1").Select
sonBulunanSatir = 1
y = 1
'Aşağıdaki bölümde ilgili sayfadaki B sütununda arama yapılıp, bulunan bilgiler aktarılıyor.
For a = 1 To 1000
bulundu = Cells.FindNext(After:=ActiveCell).Activate
'eğer bir bilgi bulunmadıysa sonraki sayfaya geçer
If bulundu <> True Then Exit For
x = ActiveCell.Column
y = ActiveCell.Row
'eğer arama işlemi başa dönerse döngüden çık diğer sayfaya geç
'yani kayıt bulunamadığında ya da son bilgi bulunup, arama başa döndüğünde
If (y <= sonBulunanSatir) Then Exit For
sonBulunanSatir = y
bilgiBulundu = True
'Bulunan bilgiler sonuç sayfasına aktarılıyor
'diğer sütunlardaki bilgiler de aynı şekilde yazılan kodlarla aktarılmalıdır.
'aşağıdaki kod üç bilgiyi aktarmaktadır
Sheets("sonuc").Cells(satir, 1) = Sheets(no).Cells(y, 1)
Sheets("sonuc").Cells(satir, 2) = Sheets(no).Cells(y, 2)
Sheets("sonuc").Cells(satir, 3) = Sheets(no).Cells(y, 3)
Sheets("sonuc").Cells(satir, 4) = Sheets(no).Cells(y, 4)
Sheets("sonuc").Cells(satir, 5) = Sheets(no).Cells(y, 5)
Sheets("sonuc").Cells(satir, 6) = Sheets(no).Cells(y, 6)
Sheets("sonuc").Cells(satir, 7) = Sheets(no).Cells(y, 7)
Sheets("sonuc").Cells(satir, 8) = Sheets(no).Cells(y, 8)
Sheets("sonuc").Cells(satir, 9) = Sheets(no).Cells(y, 9)
Sheets("sonuc").Cells(satir, 10) = Sheets(no).Cells(y, 10)
satir = satir + 1
Next a
Next Sayfa
Sheets("sonuc").Select
Range("b1").Select
Application.ScreenUpdating = True
If bilgiBulundu = False Then MsgBox Range("b1").Value + " Adında Öğrenci Bulunamadı!"
End Sub