Formül Yada Makro İle Sayfalar Arası Arama ve Yazdırma

[gicimi]

MErhaba,

Ekteki örnekte sayfa1 ve sayfa2 de veriler bulunmaktadır.

Her iki sayfadaki aranacak veriler farklı tarihlerde de yer almaktadır.

Sonuç sayfasına aranan numarayı yazdığımda sayfa1-sayfa2 de yer alan uzaklık sutunda <100 küçük ise en küçük veriyi getirmesini istiyorum.

Sayfalardaki veriler 80.000 üzeridir.

Yardımlarınızı bekliyorum.

 

[Ziynettin]

Merhaba,

Option Explicit
Sub aktar()
Dim a(), b(), i As Long, Say As Long
Dim snc As Worksheet, sh As Variant
Dim z: z = TimeValue(Now)
Set snc = Sheets("Sonuç")
Dim aranan_no: aranan_no = CStr(snc.[A2])
If aranan_no = "" Then MsgBox "A2 hücresine numara giriniz.", vbCritical: Exit Sub
Dim s1: Set s1 = Sheets("sayfa1")
Dim s2: Set s2 = Sheets("sayfa2")
Dim son1: son1 = s1.Cells(Rows.Count, 2).End(3).Row
Dim son2: son2 = s2.Cells(Rows.Count, 2).End(3).Row
ReDim b(1 To son1 + son2, 1 To 4)
    For Each sh In Array("Sayfa1", "Sayfa2")
        a = Sheets(sh).Range("B2:Q" & Sheets(sh).Cells(Rows.Count, 2).End(3).Row).Value
        For i = 1 To UBound(a)
            If a(i, 16) < 100 And CStr(a(i, 1)) = aranan_no Then
                Say = Say + 1
                b(Say, 1) = a(i, 1)
                b(Say, 2) = a(i, 6)
                b(Say, 3) = a(i, 7)
                b(Say, 4) = a(i, 16)
            End If
        Next i
        If Say > 0 Then
            snc.Range("A2:D" & Rows.Count).ClearContents
            snc.[A2].Resize(Say, 4) = b
            snc.[B2].Resize(Say).NumberFormat = "dd.mm.yyyy"
            snc.[C2].Resize(Say).NumberFormat = "hh:mm:ss"
            snc.[D2].Resize(Say).NumberFormat = "#,##0.00"
        End If
    Next sh
MsgBox "işlem tamam." & vbLf & "İşlem süreniz:  " & CDate(TimeValue(Now) - z), vbInformation
End Sub

 

[gicimi]

Merhaba,

Option Explicit
Sub aktar()
Dim a(), b(), i As Long, Say As Long
Dim snc As Worksheet, sh As Variant
Dim z: z = TimeValue(Now)
Set snc = Sheets("Sonuç")
Dim aranan_no: aranan_no = CStr(snc.[A2])
If aranan_no = "" Then MsgBox "A2 hücresine numara giriniz.", vbCritical: Exit Sub
Dim s1: Set s1 = Sheets("sayfa1")
Dim s2: Set s2 = Sheets("sayfa2")
Dim son1: son1 = s1.Cells(Rows.Count, 2).End(3).Row
Dim son2: son2 = s2.Cells(Rows.Count, 2).End(3).Row
ReDim b(1 To son1 + son2, 1 To 4)
    For Each sh In Array("Sayfa1", "Sayfa2")
        a = Sheets(sh).Range("B2:Q" & Sheets(sh).Cells(Rows.Count, 2).End(3).Row).Value
        For i = 1 To UBound(a)
            If a(i, 16) < 100 And CStr(a(i, 1)) = aranan_no Then
                Say = Say + 1
                b(Say, 1) = a(i, 1)
                b(Say, 2) = a(i, 6)
                b(Say, 3) = a(i, 7)
                b(Say, 4) = a(i, 16)
            End If
        Next i
        If Say > 0 Then
            snc.Range("A2:D" & Rows.Count).ClearContents
            snc.[A2].Resize(Say, 4) = b
            snc.[B2].Resize(Say).NumberFormat = "dd.mm.yyyy"
            snc.[C2].Resize(Say).NumberFormat = "hh:mm:ss"
            snc.[D2].Resize(Say).NumberFormat = "#,##0.00"
        End If
    Next sh
MsgBox "işlem tamam." & vbLf & "İşlem süreniz:  " & CDate(TimeValue(Now) - z), vbInformation
End Sub

Merhaba,

işlem tamamlandı uyarı veriyor ancak Sonuç kodu A sutuna numara girdiğimde veriyi getirmiyor. Kontrol edebilir misiniz.

 

[gicimi]

konu hakkında yardımcı olabilir misiniz

 

[Ömer BARAN]

Merhaba.

Sonuç sayfası A sütununa aranacak değerin elle yazılacağı varsayılmıştır.

Bir de aşağıdaki şekilde dener misiniz?
-- Alt taraftan SONUÇ sayfasının adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- Açılan VBA ekranında sağdaki boş alana aşağıdaki kod'u yapıştırın,
-- Sonuç sayfası A sütununa ARANAN NUMARAyı yazın.
.

[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
son = Cells.SpecialCells(xlCellTypeLastCell).Row
If Intersect(Target, Range("A2:A" & son)) Is Nothing Then Exit Sub
If Target = "" Then
    Range(Cells(Target.Row, 2), Cells(Target.Row, 4)).ClearContents
    Exit Sub
End If
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set wf = Application.WorksheetFunction
If wf.CountIf(s1.[B:B], Target) > 0 Then
    s1sat = wf.Match(Target, s1.[B:B], 0)
    s1deg = s1.Cells(s1sat, "Q")
End If
If wf.CountIf(s2.[B:B], Target) > 0 Then
    s2sat = wf.Match(Target, Sheets("Sayfa2").[B:B], 0)
    s2deg = s2.Cells(s2sat, "Q")
End If

If s1deg > 0 Or s2deg > 0 Then
    minn = wf.Min(s1deg, s2deg)
        If minn = s1deg And s1deg < 100 Then
            sat = s1satt
            tarih = s1.Cells(s1sat, "G")
            saat = s1.Cells(s1sat, "H")
            Cells(Target.Row, 2) = tarih
            Cells(Target.Row, 3) = Format(saat, "hh:mm:nn")
            Cells(Target.Row, 4) = s1.Cells(s1sat, "Q")
            Exit Sub
        Else
            Cells(Target.Row, 2).ClearContents
            Cells(Target.Row, 3).ClearContents
        End If
        
        If minn = s2deg And s2deg < 100 Then
            sat = s2satt
            tarih = s2.Cells(s2sat, "G")
            saat = s2.Cells(s2sat, "H")
            Cells(Target.Row, 2) = tarih
            Cells(Target.Row, 3) = Format(saat, "hh:mm:nn")
            Cells(Target.Row, 4) = s2.Cells(s1sat, "Q")
        Else
            Cells(Target.Row, 2).ClearContents
            Cells(Target.Row, 3).ClearContents
            Exit Sub
        End If
End If
s1sat = Empty: s2sat = Empty: s1deg = Empty: s2deg = Empty: tarih = Empty: saat = Empty
[B]End Sub[/B]

 

[gicimi]

Ömer Bey Merhaba,
Aram sayfasına El ile yazmıyorum. A sütununda numara sayısı 10.000 üzeri ve iki sayfa arasında aranan değerleri değiştirdiğimde veriyi güncellemiyor.