Aktarmadaki sorunu çözemedim

Serbulent_1512 · 13 Eylül 2013

Arkadaşlar eklediğim dosyada açıklama mevcut

lütfen yardım edin bu iş için 4 günüm kaldı.

şirketin formatında değişiklik yapamıyorum.

Serbulent_1512 · 17 Eylül 2013

güncel sorun devam edyor

Korhan Ayhan · 18 Eylül 2013

Merhaba,

Ekteki örnek dosyayı inceleyiniz.

Çalışmanıza GÜN adlı bir sayfa ekledim.

Makro çalıştığında "VERİ" - "YILLIK" - "GÜN" isimli sayfaların dışındaki tüm sayfaları silmektedir. Daha sonra günlere ait sayfalar sıfırdan oluşturulup işleme devam edilmektedir. Bu sebeple orjinal çalışmanızda bunların dışında silinmemesi gereken sayfalar varsa kodu çalıştırmayınız. Bu sayfa isimlerini kodun içine ekleyip o şekilde çalıştırmanız gerekmektedir. Kodun içinde kırmızı renkle belirttiğim bölüme silinmemesi gereken sayfa isimlerinizi ekleyebilirsiniz.

Aşağıdaki kod kullanılmıştır.

Kod:

Option Explicit

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, S4 As Worksheet, Sayfa As Worksheet
    Dim Yil As Variant, Sutun As Integer, Satir As Long, Ay As String, Alan As Range, Veri As Range
    Dim Bul_Ay As Range, Bul_Veri As Range, Son_Satir As Long
    
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YILLIK")
    Set S3 = Sheets("GÜN")

    Yil = InputBox("Lütfen oluşturmak istediğiniz yılı giriniz...", , Year(Date) + 1)
    If Yil = "" Or Yil = False Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each Sayfa In ThisWorkbook.Worksheets
        Select Case Sayfa.Name
            Case [COLOR="Red"]"VERİ", "YILLIK", "GÜN"[/COLOR]
            Case Else
                Sayfa.Delete
        End Select
    Next
    
    Application.DisplayAlerts = True

    S2.Range("A3:N" & Rows.Count).ClearContents

    For Sutun = 2 To S1.Cells(2, 2).End(2).Column
        If S1.Cells(2, Sutun) = 1 Then Ay = S1.Cells(1, Sutun)
        If WorksheetFunction.CountA(S1.Range(S1.Cells(3, Sutun), S1.Cells(Rows.Count, Sutun))) > 0 Then
            On Error Resume Next
            Set Alan = S1.Range(S1.Cells(3, Sutun), S1.Cells(Rows.Count, Sutun)).SpecialCells(xlCellTypeConstants, 23)
            On Error GoTo 0
            If Not Alan Is Nothing Then
                S3.Copy , Sheets(Sheets.Count)
                Set S4 = ActiveSheet
                S4.Name = S1.Cells(2, Sutun) & "_" & Ay
                Satir = 2
                For Each Veri In Alan
                    If UCase(Veri) = "X" Then
                        On Error Resume Next
                        S4.Cells(Satir, 1) = CDate(S1.Cells(2, Sutun) & "." & Ay & "." & Yil)
                        If Err.Number = 13 Then
                            MsgBox Yil & " yılının " & Ay & " ayı 29 çekmemektedir!" & Chr(10) & _
                                   "Lütfen sayfadaki tarihlerinizi kontrol ediniz!" & Chr(10) & _
                                   "Diğer günlerden işleme devam edilecektir!", vbCritical
                            Application.DisplayAlerts = False
                            S4.Delete
                            Application.DisplayAlerts = True
                            Err.Clear
                            GoTo 10
                        End If
                        On Error GoTo 0
                        S4.Cells(Satir, 2) = S1.Cells(Veri.Row, 1)
                        Satir = Satir + 1
                    
                        Set Bul_Ay = S2.Rows(2).Find(Ay)
                        If Not Bul_Ay Is Nothing Then
                            Set Bul_Veri = S2.Range("B:B").Find(S1.Cells(Veri.Row, 1))
                            If Not Bul_Veri Is Nothing Then
                                If S2.Cells(Bul_Veri.Row, Bul_Ay.Column) = "" Then
                                    S2.Cells(Bul_Veri.Row, Bul_Ay.Column) = S1.Cells(2, Sutun)
                                Else
                                    Son_Satir = S2.Cells(Rows.Count, 2).End(3).Row + 1
                                    S2.Cells(Son_Satir, 1) = WorksheetFunction.Max(S2.Range("A:A")) + 1
                                    S2.Cells(Son_Satir, 2) = S1.Cells(Veri.Row, 1)
                                    S2.Cells(Son_Satir, Bul_Ay.Column) = S1.Cells(2, Sutun)
                                End If
                            Else
                                Son_Satir = S2.Cells(Rows.Count, 2).End(3).Row + 1
                                S2.Cells(Son_Satir, 1) = WorksheetFunction.Max(S2.Range("A:A")) + 1
                                S2.Cells(Son_Satir, 2) = S1.Cells(Veri.Row, 1)
                                S2.Cells(Son_Satir, Bul_Ay.Column) = S1.Cells(2, Sutun)
                            End If
                        End If
                    End If
                Next
10          End If
        End If
    Next
    
    S1.Select
    
    Set Alan = Nothing
    Set Bul_Ay = Nothing
    Set Bul_Veri = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Serbulent_1512 · 20 Eylül 2013

çok teşekkürler....

Serbulent_1512 · 20 Eylül 2013

Bu şekildeki çalışmada her güne bir sayfa yapılıyor. Ben her aya ait yapılacakları bir sayfada toplamasını istiyorum. (Gün gün değilde ay ay sayfalayacak)
Bunu yapabilirmiyiz?

Korhan Ayhan · 21 Eylül 2013

Bu durumda aşağıdaki kodu kullanabilirsiniz.

Not : GÜN isimli sayfanın adını AY olarak değiştirip kodu deneyiniz.

Kod:

Option Base 1

Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, S4 As Worksheet, Sayfa As Worksheet
    Dim Yil As Variant, Sutun As Integer, Satir As Long, Ay As String, Alan As Range, Veri As Range
    Dim Bul_Ay As Range, Bul_Veri As Range, Son_Satir As Long, Gun As Byte, Ay_Adi() As Variant
    
    Yil = InputBox("Lütfen oluşturmak istediğiniz yılı giriniz...", , Year(Date) + 1)
    If Yil = "" Or Yil = False Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set S1 = Sheets("VERİ")
    Set S2 = Sheets("YILLIK")
    Set S3 = Sheets("AY")

    Ay_Adi = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
    
    For Each Sayfa In ThisWorkbook.Worksheets
        Select Case Sayfa.Name
            Case "VERİ", "YILLIK", "AY"
            Case Else
                Sayfa.Delete
        End Select
    Next
    
    Application.DisplayAlerts = True

    S2.Range("A3:N" & Rows.Count).ClearContents

    For Sutun = 2 To S1.Cells(2, 2).End(2).Column
        If S1.Cells(2, Sutun) = 1 Then Ay = S1.Cells(1, Sutun)
        If WorksheetFunction.CountA(S1.Range(S1.Cells(3, Sutun), S1.Cells(Rows.Count, Sutun))) > 0 Then
            On Error Resume Next
            Set Alan = S1.Range(S1.Cells(3, Sutun), S1.Cells(Rows.Count, Sutun)).SpecialCells(xlCellTypeConstants, 23)
            On Error GoTo 0
            If Not Alan Is Nothing Then
                If Not Sayfa_Varmi(Ay) Then
                    S3.Copy , Sheets(Sheets.Count)
                    Set S4 = ActiveSheet
                    S4.Name = Ay
                    Satir = 2
                Else
                    Set S4 = Sheets(Ay)
                    Satir = S4.Cells(Rows.Count, 1).End(3).Row + 1
                End If
                
                For Each Veri In Alan
                    If UCase(Veri) = "X" Then
                        If Ay <> Ay_Adi(Month(DateSerial(Yil, Application.WorksheetFunction.Match(Ay, Ay_Adi(), 0), S1.Cells(2, Sutun)))) Then
                            If Ay = "ŞUBAT" Then
                                Gun = 29
                            Else
                                Gun = 31
                            End If
                            
                            MsgBox Yil & " yılının " & Ay & " ayı " & Gun & " çekmemektedir!" & Chr(10) & _
                                   "Lütfen sayfadaki tarihlerinizi kontrol ediniz!" & Chr(10) & _
                                   "Diğer günlerden işleme devam edilecektir!", vbCritical
                            GoTo 10
                        End If

                        S4.Cells(Satir, 1) = CDate(DateSerial(Yil, Application.WorksheetFunction.Match(Ay, Ay_Adi, 0), S1.Cells(2, Sutun)))
                        S4.Cells(Satir, 2) = S1.Cells(Veri.Row, 1)
                        Satir = Satir + 1
                    
                        Set Bul_Ay = S2.Rows(2).Find(Ay)
                        If Not Bul_Ay Is Nothing Then
                            Set Bul_Veri = S2.Range("B:B").Find(S1.Cells(Veri.Row, 1))
                            If Not Bul_Veri Is Nothing Then
                                If S2.Cells(Bul_Veri.Row, Bul_Ay.Column) = "" Then
                                    S2.Cells(Bul_Veri.Row, Bul_Ay.Column) = S1.Cells(2, Sutun)
                                Else
                                    Son_Satir = S2.Cells(Rows.Count, 2).End(3).Row + 1
                                    S2.Cells(Son_Satir, 1) = WorksheetFunction.Max(S2.Range("A:A")) + 1
                                    S2.Cells(Son_Satir, 2) = S1.Cells(Veri.Row, 1)
                                    S2.Cells(Son_Satir, Bul_Ay.Column) = S1.Cells(2, Sutun)
                                End If
                            Else
                                Son_Satir = S2.Cells(Rows.Count, 2).End(3).Row + 1
                                S2.Cells(Son_Satir, 1) = WorksheetFunction.Max(S2.Range("A:A")) + 1
                                S2.Cells(Son_Satir, 2) = S1.Cells(Veri.Row, 1)
                                S2.Cells(Son_Satir, Bul_Ay.Column) = S1.Cells(2, Sutun)
                            End If
                        End If
                    End If
                Next
10          End If
        End If
    Next
    
    S1.Select
    
    Set Alan = Nothing
    Set Bul_Ay = Nothing
    Set Bul_Veri = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Function Sayfa_Varmi(Sayfa_Adi As String) As Boolean
    On Error Resume Next
    Sayfa_Varmi = CBool(Len(Worksheets(Sayfa_Adi).Name) > 0)
End Function

Serbulent_1512 · 21 Eylül 2013

Kodu yazdım. Ancak Nisan ayı 29 çekmiyor diye uyarı verdi. Dosya Ek-te

Korhan Ayhan · 22 Eylül 2013

Üstteki mesajımda ki kodu güncelledim. Tekrar deneyiniz.

tahsinanarat · 22 Eylül 2013

Sn. Korhan Hocam, Ocak ayında x olduğu halde işleme almıyor, bilginize.

Korhan Ayhan · 22 Eylül 2013

Gün denemesi yaparken döngü başlangıcını yüksek tutmuştum. Bu sebeple aktarmamıştır. Sonradan fark edince düzelttim. Tekrar deneyiniz.

Aktarmadaki sorunu çözemedim

Serbulent_1512

Ekli dosyalar

Serbulent_1512

Korhan Ayhan

Administrator

Ekli dosyalar

Serbulent_1512

Serbulent_1512

Ekli dosyalar

Korhan Ayhan

Administrator

Serbulent_1512

Ekli dosyalar

Korhan Ayhan

Administrator

tahsinanarat

Korhan Ayhan

Administrator