• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

E

EKREM1661

Katılım
10 Kasım 2006
Mesajlar
1,288
Excel Vers. ve Dili
Excel-2016
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:
Dosyada makro göremedim!
 
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
 
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
 
Ö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..
 
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
 
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:
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
 
Ü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.
Geri
Üst