Sayfalara ayrıştırma

[sarigozoglu]

Sevgili arkadaşlar ekteki örnek tabloya göre sayfalara ayrıştırma işlemi yapmak istiyorum.

Forumda epey araştırdım, fakat genel örneklemeler komple satır aktarma yönünde.

Benim örneğimde ayrıştırılacak veriler, anahtar veriye göre farklılık göstermekle birlikte aktarıldıkları sayfalarda da yine anahtar veriye göre farklı satırlara gidebiliyor.

Yardımlarınız için şimdiden teşekkür ederim.

Örnek dosya ektedir.

 

[Ömer]

Merhaba,

Aktarım sırasında eski sayfalarda eski verilerin devamına yazar.

Sub Sayfalara_Dagit()

    Dim S1 As Worksheet, i As Long, son As Long
    
    Set S1 = Sheets("Sayfa1")
    
    Application.ScreenUpdating = False
    On Error GoTo atla
    
    For i = 5 To S1.Cells(Rows.Count, "F").End(xlUp).Row
        With Sheets("" & S1.Cells(i, "F") & "")
            son = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Cells(son, "A") = S1.Cells(i, "D")
            .Cells(son, "B") = S1.Cells(i, "C")
            .Cells(son, "C") = S1.Cells(i, "G")
            .Cells(son, "D") = S1.Cells(i, "H")
            .Cells(son, "E") = S1.Cells(i, "I")
        End With
    Next i
Exit Sub
atla:
    MsgBox S1.Cells(i, "F") & " Sayfasını Bulamadığım İçin İşlemi Burada Durdurdum."
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[sarigozoglu]

Teşekkürler
Eski veriler silinecek demeyi unutmuşum ben tabi

Dizel ve Benzin sekmelerine atarken toplam fiyat gelmedi

 

[Ömer]

Sayfa formatları farklı mı?

Dizel ve benzinde "KM" sütunu var fakat lpg ve hibrit de yok.

.

 

[sarigozoglu]

Evet yok, sayfa formatları birbirinden farklı.
İkisi başka, ikisi başka.

 

[Ömer]

Bu durumda Sayfa1 başlıklar ile şart sayfalarındaki başlık isimlerinin aynı olmasına dikkat edin.

Örneğin Sayfa1 C4 de bulunan MODELNO değerini boşluk bırakarak yazın. MODEL NO gibi.

Sub Sayfalara_Dagit()

    Dim S1 As Worksheet, i As Long, son As Long, j As Integer
    Dim c As Range, sat As Long
    
    Set S1 = Sheets("Sayfa1")
    
    Application.ScreenUpdating = False
        
    On Error Resume Next
    For i = 1 To Worksheets.Count
        With Sheets(i)
            If .Name <> "Sayfa1" Then
                sat = .Range("A1").End(xlDown).Row + 1
                .Range(.Cells(sat, "A"), _
                    .Cells(Rows.Count, Columns.Count)).ClearContents
            End If
        End With
    Next i
                
    On Error GoTo atla
    For i = 5 To S1.Cells(Rows.Count, "F").End(xlUp).Row
        With Sheets("" & S1.Cells(i, "F") & "")
            son = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            sat = .Range("A1").End(xlDown).Row
            For j = 1 To .Cells(sat, Columns.Count).End(xlToLeft).Column
                Set c = S1.Rows(4).Find(.Cells(sat, j), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    .Cells(son, j) = S1.Cells(i, c.Column)
                End If
            Next j
        End With
    Next i
Exit Sub
atla:
    MsgBox S1.Cells(i, "F") & " Sayfasını Bulamadığım" _
            & "İçin İşlemi Burada Durdurdum."
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[sarigozoglu]

Çok teşekkür ederim ellerinize sağlık.

Çok önemli mi bilmiyorum ama işlem bittiğinde tüm sayfalar tam olmasına rağmen
"Sayfasını bulamadığım için......" şeklinde mesajı veriyor. Düzeltip düzeltmemek sizin takdirinize kalmış.

Diğer bir taraftan böyle bir mesaj vermek yerine sayfaları otomatik oluşturmasını sağlayamaz mıyız ?

 

[Ömer]

atla:

satırından önce aşağıdaki satırı ilave edin.

Exit Sub

Yukarıdaki mesajları düzelttim.

.

 

[Ömer]

Diğer bir taraftan böyle bir mesaj vermek yerine sayfaları otomatik oluşturmasını sağlayamaz mıyız ?

Farklı sayfa formatları kullanıyorsunuz. Hangi sayfanın formatında yeni sayfa açılacak?

.