Sayfalara aktarılan tarihli verilerin, tarih sırasına göre aktarılması..

E

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,285
Excel Vers. ve Dili
Excel-2016
Altın Üyelik Bitiş Tarihi
03-02-2026
Saygıdeğer hocalarım.!

Ekli örnek dosyada; bir tablo bilgilerini (İsim, Tarih ve Çalışma saati) sayfalara aktarma konusunda, Korhan Ayhan hocamın geçmiş yıllarda yazdığı kodları kullanıyorum.. Buna ilave olarak, verilerin aktarıldığı sayfalara tarih sırasına göre aktarılmasını sağlayabilir miyiz.?
 

Ekli dosyalar

Son düzenleme:
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,071
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Dosyada makro göremedim!
 
E

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,285
Excel Vers. ve Dili
Excel-2016
Altın Üyelik Bitiş Tarihi
03-02-2026
Yusuf bey.. Makro, sayfanın kod bölümündedir..

Kod: 
Private Sub CommandButton3_Click()

Dim sh As Worksheet, i As Long, k As Integer, ad As String, sonsat As Long
Dim sat As Long
For Each sh In Worksheets
    If Left(sh.Name, 4) = "İsim" Then sh.Range("B9:B39,F9:F39").ClearContents
Next sh
For k = 3 To 15 Step 2
    sonsat = Cells(Rows.Count, k).End(xlUp).Row
    For i = 4 To sonsat
        ad = Cells(i, k).Value
        For Each sh In Worksheets
            If ad = sh.Cells(3, "D").Value And ad <> "" Then
                sat = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
                sh.Cells(sat, "B").Value = Cells(i, "A").Value
                sh.Cells(sat, "F").Value = Cells(i, k + 1).Value
                ad = "": Exit For
            End If
        Next sh
    Next i
Next k
MsgBox "Aktarma işlemleri sorunsuz tamamlanmıştır.." & vbCrLf & " " & vbCrLf & "ekrem.1661@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,071
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Sayfa çok olunca dikkat etmemişim :(

Aşağıdaki kodu deneyin:

PHP: 
Private Sub CommandButton3_Click() 'bilgileri kişisel isim sayfalarına aktarım..
Uyarı = MsgBox("Tablo bilgileri tasniflenerek kişisel isim sayfalarına atılacak.." & vbCrLf & "Bu işlem 1-2 dakika sürebilir..  Sonuç iletisini bekleyiniz..! " & vbCrLf & " " & vbCrLf & "Devam Edilsin mi?", vbSystemModal + vbInformation + vbYesNo, "KAYIT BİLGİSİ")
If Uyarı = 6 Then
Else: Exit Sub
End If
'Sub Sayfalara-at()
Dim sh As Worksheet, i As Long, k As Integer, ad As String, sonsat As Long
Dim sat As Long
For Each sh In Worksheets
    If Left(sh.Name, 4) = "İsim" Then sh.Range("B9:B39,F9:F39").ClearContents
Next sh
For k = 3 To 15 Step 2
    sonsat = Cells(Rows.Count, k).End(xlUp).Row
    For i = 4 To sonsat
        ad = Cells(i, k).Value
        For Each sh In Worksheets
            If ad = sh.Cells(3, "D").Value And ad <> "" Then
                sat = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
                sh.Cells(sat, "B").Value = Cells(i, "A").Value
                sh.Cells(sat, "F").Value = Cells(i, k + 1).Value
                ad = "": Exit For
            End If
        Next sh
    Next i
Next k

For Each sh In Worksheets
    sh.Sort.SortFields.Clear
    sh.Sort.SortFields.Add Key:=Range("B9:B39") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With sh.Sort
        .SetRange Range("B9:F39")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Next sh
MsgBox "Aktarma işlemleri sorunsuz tamamlanmıştır.." & vbCrLf & " " & vbCrLf & "ekrem.1661@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub
 
E

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,285
Excel Vers. ve Dili
Excel-2016
Altın Üyelik Bitiş Tarihi
03-02-2026
Öncelikle teşekkürler Yusuf hocam, oldu olmasına da, (işlem yaptığım sayfalarda dahil) işlemi tüm sayfalara uyguladı. Yalnız, İsim.1, İsim.2, İsim.3...... diye devam eden sayfalara uygulaması lazım.. Sadece İsim sayfalarına sınırlı tutarsak bu iş olacak..
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,071
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Pardon, ona dikkat etmemişim :(

PHP: 
Private Sub CommandButton3_Click() 'bilgileri kişisel isim sayfalarına aktarım..
Uyarı = MsgBox("Tablo bilgileri tasniflenerek kişisel isim sayfalarına atılacak.." & vbCrLf & "Bu işlem 1-2 dakika sürebilir..  Sonuç iletisini bekleyiniz..! " & vbCrLf & " " & vbCrLf & "Devam Edilsin mi?", vbSystemModal + vbInformation + vbYesNo, "KAYIT BİLGİSİ")
If Uyarı = 6 Then
Else: Exit Sub
End If
'Sub Sayfalara-at()
Dim sh As Worksheet, i As Long, k As Integer, ad As String, sonsat As Long
Dim sat As Long
For Each sh In Worksheets
    If Left(sh.Name, 4) = "İsim" Then sh.Range("B9:B39,F9:F39").ClearContents
Next sh
For k = 3 To 15 Step 2
    sonsat = Cells(Rows.Count, k).End(xlUp).Row
    For i = 4 To sonsat
        ad = Cells(i, k).Value
        For Each sh In Worksheets
            If ad = sh.Cells(3, "D").Value And ad <> "" Then
                sat = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
                sh.Cells(sat, "B").Value = Cells(i, "A").Value
                sh.Cells(sat, "F").Value = Cells(i, k + 1).Value
                ad = "": Exit For
            End If
        Next sh
    Next i
Next k

For Each sh In Worksheets
    If Left(sh.Name, 4) = "İsim" Then
        sh.Sort.SortFields.Clear
        sh.Sort.SortFields.Add Key:=Range("B9:B39") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With sh.Sort
            .SetRange Range("B9:F39")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
Next sh
MsgBox "Aktarma işlemleri sorunsuz tamamlanmıştır.." & vbCrLf & " " & vbCrLf & "ekrem.1661@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub
 
E

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,285
Excel Vers. ve Dili
Excel-2016
Altın Üyelik Bitiş Tarihi
03-02-2026
Yusuf hocam ziyadesiyle teşekkür ederim, elinize sağlık, çok makbule geçti.. (Hocam, kod çalıştıktan sonra "sayfa.1".... devam eden sayfalarında, sıraya koyduğu aralığı seçili bırakıyor. Kodun sonuna Range("A7").Select ifadesi ekledim yine değişmedi. Bunun için..?)
 
Son düzenleme:
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,071
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki gibi deneyin:

PHP: 
Private Sub CommandButton3_Click() 'bilgileri kişisel isim sayfalarına aktarım..
Uyarı = MsgBox("Tablo bilgileri tasniflenerek kişisel isim sayfalarına atılacak.." & vbCrLf & "Bu işlem 1-2 dakika sürebilir..  Sonuç iletisini bekleyiniz..! " & vbCrLf & " " & vbCrLf & "Devam Edilsin mi?", vbSystemModal + vbInformation + vbYesNo, "KAYIT BİLGİSİ")
If Uyarı = 6 Then
Else: Exit Sub
End If
'Sub Sayfalara-at()
Dim sh As Worksheet, i As Long, k As Integer, ad As String, sonsat As Long
Dim sat As Long
For Each sh In Worksheets
    If Left(sh.Name, 4) = "İsim" Then sh.Range("B9:B39,F9:F39").ClearContents
Next sh
For k = 3 To 15 Step 2
    sonsat = Cells(Rows.Count, k).End(xlUp).Row
    For i = 4 To sonsat
        ad = Cells(i, k).Value
        For Each sh In Worksheets
            If ad = sh.Cells(3, "D").Value And ad <> "" Then
                sat = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
                sh.Cells(sat, "B").Value = Cells(i, "A").Value
                sh.Cells(sat, "F").Value = Cells(i, k + 1).Value
                ad = "": Exit For
            End If
        Next sh
    Next i
Next k

Application.ScreenUpdating = False
For Each sh In Worksheets
    If Left(sh.Name, 4) = "İsim" Then
        sh.Sort.SortFields.Clear
        sh.Sort.SortFields.Add Key:=Range("B9:B39") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With sh.Sort
            .SetRange Range("B9:F39")
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        sh.Activate
        sh.[A7].Select
    End If
Next sh
Sheets("Sayfa2").Activate
Application.ScreenUpdating = True
MsgBox "Aktarma işlemleri sorunsuz tamamlanmıştır.." & vbCrLf & " " & vbCrLf & "ekrem.1661@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub
 
E

EKREM1661

Altın Üye
Katılım
10 Kasım 2006
Mesajlar
1,285
Excel Vers. ve Dili
Excel-2016
Altın Üyelik Bitiş Tarihi
03-02-2026
Üstad.. Tekrar tekrar teşekkürler, hoşça kalınız ve hayırlı ramazanlar..
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst