Sayfalarda ara-bul ve listele

[dragon44760]

Herkese iyi akşamlar.

Ekli dosyanın "ANA" sayfası "E3" hücresinde yazılı olan tarihi diğer sayfalarda arıyor-buluyor listeliyor. Ancak bazı sayfalarda "ANA" sayfa "E3" de yazılı tarihi bulamamakta.

Ayrıntılı bilgi dosyada..

Yardımcı olursanız sevinirim...

 

[dragon44760]

Yardımcı olacak yok mu_?

 

[Korhan Ayhan]

Merhaba,

"sn" isimli değişkeninizi aşağıdaki gibi değiştirip deneyiniz.

sn = 112

 

[dragon44760]

Korhan Ayhan hocam ilginiz için teşekkür ederim. Değişiklik sonunda iki dosyayı düzgünce aktarmakta ama üçüncü dosyaların bilgileri ana sayfaya yanlış aktarılmakta

Örneğin; Hüseyin KELEK'in F24 de bulunan tarihin bulunduğu dosya no ve icra dairesi adı yanlış aktarılmakta

 

[dragon44760]

Sn.Korhan Ayhan emeğinize ve bilginize sağlık diyorum. Sizin düzeltiğiniz yerden sonra kodda küçük değişiklikler yaparak sonuca ulaştım. Her şey için teşekkürler...

Sub ara()
Dim s1 As Worksheet
Dim sh As Worksheet
Dim i As Long
Set s1 = Sheets("ANA")
Dim ara As Date
ara = s1.Range("e3").Value
x = 0
son = s1.Cells(65536, 1).End(xlUp).Row
If s1.Range("e3").Value = "" Then
MsgBox "Lütfen 'E3 Hücresine' Tarih Giriniz...      ", vbOKOnly + vbInformation, "TARİH YAZ..!"
s1.Range("e3").Select
Else
Application.ScreenUpdating = False
s1.Range("D7:I31").ClearContents

For Each sh In Worksheets
   If sh.Name = "ANA" Then ' Or sh.Name <> "Boş" Then
   Else
      For i = 13 To 112
          For j = 3 To 75 Step 3
               If ara = sh.Cells(i, j) Then
                  s1.Cells(7 + x, 4) = sh.Cells(2, 2)
                  s1.Cells(7 + x, 5) = sh.Cells(7, 2)
                  s1.Cells(7 + x, 6) = sh.Cells(i - i + 3, j + 2) 'dosya no
                  s1.Cells(7 + x, 7) = sh.Cells(i - i + 4, j + 2) & " " & sh.Cells(i - i + 5, j + 2)
                  s1.Cells(7 + x, 8) = sh.Cells(i, j + 1) 'tutar
                  s1.Cells(7 + x, 9) = sh.Cells(8, 2) 'Kişi no
                x = x + 1
                End If
          Next j
       Next i
     End If
 Next

Application.ScreenUpdating = True
MsgBox "Aktarma İşlemi Tamamlanmıştır. ", vbOKOnly + vbInformation, "İŞLEM TAMAMLANDI..!"
End If
End Sub