Kriterlere göre sayfadan veri alma

E

excellkurdu

Altın Üye
Katılım
16 Nisan 2008
Mesajlar
313
Excel Vers. ve Dili
Türkçe Microsoft Office Excel 2007
Altın Üyelik Bitiş Tarihi
22-03-2026
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
 

Ekli dosyalar

Son düzenleme:
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,330
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
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
 
E

excellkurdu

Altın Üye
Katılım
16 Nisan 2008
Mesajlar
313
Excel Vers. ve Dili
Türkçe Microsoft Office Excel 2007
Altın Üyelik Bitiş Tarihi
22-03-2026
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
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
Genişletmek için tıkla ...
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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,330
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bu durumda aşağıdaki kodu deneyebilirsiniz.

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

C++: 
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
 
E

excellkurdu

Altın Üye
Katılım
16 Nisan 2008
Mesajlar
313
Excel Vers. ve Dili
Türkçe Microsoft Office Excel 2007
Altın Üyelik Bitiş Tarihi
22-03-2026
Korhan Ayhan' Alıntı:
Bu durumda aşağıdaki kodu deneyebilirsiniz.

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

C++: 
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
Genişletmek için tıkla ...
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
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,330
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Hakkım varsa helal olsun..
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst