Kriterlere göre sayfadan veri alma

[excellkurdu]

Ustalarım bir konuda yardımınıza ihtiyacım var. Şimdiden teşekkür ederim.
Veri al macrosuyla, A73 ile ESE993 arasındaki verilerimden son tarihe ait Satırdaki sadece Numara olanları "Istasyonlar" sayfasına listelemek istiyorum.
No lar F sutunundan başlıyor 10 ar sütünda birdir.
Aynı kod la 125 adet veri alacağımdan dolayı Fonksiyon formüllerinden kacınıyorum.
Saygılarımla

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Tarih As Date
    Dim Bul As Range, Sutun As Integer, Zaman As Double
    Dim X As Integer, Y As Integer, Say As Long, Son As Integer
    
    Zaman = Timer
    
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Istasyonlar")
    
    S2.Range("D8:Z" & S2.Rows.Count).Clear
    S2.Cells.ColumnWidth = 8.43
    
    Tarih = WorksheetFunction.Max(S1.Range("C:C"))
    
    Set Bul = S1.Range("C:C").Find(CDate(Tarih), LookIn:=xlValues, Lookat:=xlWhole)
    
    ReDim Liste(1 To WorksheetFunction.CountA(S1.Range("A:A")), 1 To 10)
    
    For X = 6 To S1.Cells(72, S1.Columns.Count).End(1).Column Step 10
        If S1.Cells(73, X) <> "" And S1.Cells(Bul.Row, X) <> "" And S1.Cells(Bul.Row, X) <> 0 Then
            Say = Say + 1
            Sutun = 1
            Liste(Say, 1) = S1.Cells(Bul.Row, X)
            For Y = X + 1 To X + 9
                If IsNumeric(S1.Cells(Bul.Row, Y)) And S1.Cells(Bul.Row, Y) <> "" Then
                    Sutun = Sutun + 1
                    Liste(Say, Sutun) = S1.Cells(Bul.Row, Y)
                End If
                If Son < Sutun Then Son = Sutun
            Next
        End If
    Next

    If Say > 0 Then
        S2.Range("D9").Resize(Say, Son) = Liste
        For X = 1 To Son
            S2.Cells(8, X + 3) = "No-" & X
            S2.Cells(8, X + 3).Font.Bold = True
            S2.Select
        Next
        S2.Columns.AutoFit
    
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[excellkurdu]

Deneyiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Tarih As Date
    Dim Bul As Range, Sutun As Integer, Zaman As Double
    Dim X As Integer, Y As Integer, Say As Long, Son As Integer
   
    Zaman = Timer
   
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Istasyonlar")
   
    S2.Range("D8:Z" & S2.Rows.Count).Clear
    S2.Cells.ColumnWidth = 8.43
   
    Tarih = WorksheetFunction.Max(S1.Range("C:C"))
   
    Set Bul = S1.Range("C:C").Find(CDate(Tarih), LookIn:=xlValues, Lookat:=xlWhole)
   
    ReDim Liste(1 To WorksheetFunction.CountA(S1.Range("A:A")), 1 To 10)
   
    For X = 6 To S1.Cells(72, S1.Columns.Count).End(1).Column Step 10
        If S1.Cells(73, X) <> "" And S1.Cells(Bul.Row, X) <> "" And S1.Cells(Bul.Row, X) <> 0 Then
            Say = Say + 1
            Sutun = 1
            Liste(Say, 1) = S1.Cells(Bul.Row, X)
            For Y = X + 1 To X + 9
                If IsNumeric(S1.Cells(Bul.Row, Y)) And S1.Cells(Bul.Row, Y) <> "" Then
                    Sutun = Sutun + 1
                    Liste(Say, Sutun) = S1.Cells(Bul.Row, Y)
                End If
                If Son < Sutun Then Son = Sutun
            Next
        End If
    Next

    If Say > 0 Then
        S2.Range("D9").Resize(Say, Son) = Liste
        For X = 1 To Son
            S2.Cells(8, X + 3) = "No-" & X
            S2.Cells(8, X + 3).Font.Bold = True
            S2.Select
        Next
        S2.Columns.AutoFit
   
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

Hocam emeğinize sağlık.
2 tane sorun var.
1. si, bazı numara yerleri ya "0" ya da "boş". 300 tane numara var. Bunlar değişken; o no ları bazen siliyoruz, bazen no ekliyoruz. Eğer boş ya da sıfır ise hücre değeri aynen listeye eklenmeli.

Örneğin No yazan yerlerdeki değerler ne ise onu listelesin:
z1
z2
0 (burada numara yoksa hücre değerini aynen alsın)
z4
....
z298
0
z299
z300

2. sorun: Bana sadece D sutunu veri alması yeterli. Yani liste halinde D sutununa getirmesi kafi. E - I arası gereksiz. E-I arası farklı yerden veri alacak ondan ekledim.

 

[Korhan Ayhan]

Bu durumda aşağıdaki kodu deneyebilirsiniz.

Dosyanızda "z135" kodlu istasyondan sonra sütunsal olarak kayma var. Bunu düzeltmelisiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Tarih As Date
    Dim X As Integer, Say As Long, Bul As Range, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Istasyonlar")
   
    S2.Range("D9:D" & S2.Rows.Count).Clear
    S2.Cells.ColumnWidth = 8.43
   
    Tarih = WorksheetFunction.Max(S1.Range("C:C"))
   
    Set Bul = S1.Range("C:C").Find(CDate(Tarih), LookIn:=xlValues, Lookat:=xlWhole)
   
    ReDim Liste(1 To S1.Rows.Count, 1 To 1)
   
    For X = 6 To 3862 Step 10
        Say = Say + 1
        Liste(Say, 1) = S1.Cells(Bul.Row, X)
    Next

    If Say > 0 Then
        S2.Range("D9").Resize(Say, 1) = Liste
        S2.Select
        S2.Columns.AutoFit
   
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[excellkurdu]

Bu durumda aşağıdaki kodu deneyebilirsiniz.

Dosyanızda "z135" kodlu istasyondan sonra sütunsal olarak kayma var. Bunu düzeltmelisiniz.

Option Explicit

Sub Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Tarih As Date
    Dim X As Integer, Say As Long, Bul As Range, Zaman As Double
 
    Zaman = Timer
 
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Istasyonlar")
 
    S2.Range("D9:D" & S2.Rows.Count).Clear
    S2.Cells.ColumnWidth = 8.43
 
    Tarih = WorksheetFunction.Max(S1.Range("C:C"))
 
    Set Bul = S1.Range("C:C").Find(CDate(Tarih), LookIn:=xlValues, Lookat:=xlWhole)
 
    ReDim Liste(1 To S1.Rows.Count, 1 To 1)
 
    For X = 6 To 3862 Step 10
        Say = Say + 1
        Liste(Say, 1) = S1.Cells(Bul.Row, X)
    Next

    If Say > 0 Then
        S2.Range("D9").Resize(Say, 1) = Liste
        S2.Select
        S2.Columns.AutoFit
 
        MsgBox "İşleminiz tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

Hocam sizi çok yordum. Dolu alanlarda çalıştı ama Yeşil ile işaretli alanlara veri eklediğim zaman ya da sildiğim zaman hata verdi. Format yapı ekli dosyada

 

[Korhan Ayhan]

Son paylaştığım kodu denediniz mi?

 

[excellkurdu]

Son paylaştığım kodu denediniz mi?

Hocam yordum sizi, hakkınızı helal edin. Çok güzel oldu. Allah Razı olsun sizden.

 

[Korhan Ayhan]

Hakkım varsa helal olsun..