sayfalardaki verileri tek bir sayfada birleştirme

[incsoft]

Arkadaşlar elimde kullanmakta olduğum bir dosyam var ve burdaki verileri aylık özet rapor için tek bir sayfada toplamak istiyorum. Sitede bazı formüller buldum ancak birleştirilmiş hücrelerde çalışmıyor. Ekte örnekte de belirttiğim gibi istediğim 01-02-03-04 nolu sayfalarda mavi renkle işaretlenmiş alanlardaki B14:AK26 alanlarında bulunan dolu verileri KALİTE PROBLEMLERİ sayfasına satır satır aktarmaktır. Aktarmada 01-02-03-04-05.....31 şeklinde olacaktır. Bunun için nasıl bir yöntem uygulayabilirim?

Teşekkürler.

 

[incsoft]

Arkadaşlar nasıl bir çözüm bulabilirim?

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub rapor()
uyarı = MsgBox("KALİTE PROBLEMLERİ sayfasındaki eski veriler silinsin mi?", vbYesNo)
Set s1 = Sheets("KALİTE PROBLEMLERİ")
If uyarı = vbYes Then
    eski = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "B").End(3).Row)
    s1.Range("B3:AK" & eski) = ""
End If
For sayfa = 1 To Sheets.Count
    If Sheets(sayfa).Name <> s1.Name Then
        yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
        Sheets(sayfa).[B14:AK26].Copy s1.Cells(yeni, "B")
    End If
    son = s1.Cells(Rows.Count, "B").End(3).Row + 1
    s1.Range("B" & son & ":AK" & son).Borders.Weight = xlThick
    s1.Range("B2:AD" & son).Interior.Color = xlNone
Next
End Sub

 

[incsoft]

Yusuf bey bazı sayfalardaki verileri nedense almıyor. Sadece 01 sayfasını alıyor sanırım.

 

[YUSUF44]

Kod, adı KALİTE PROBLEMLERİ olmayan tüm sayfaların B14:AK26 hücrelerini kopyalar. Dosyayı hatalı haliyle yükleyin inceleyelim.

 

[incsoft]

Yusuf bey alıntı yaparak yeniden dosyayı gönderemiyorum. Macro nuzu bir butona ekledim ancak sadece KALİTE PROBLEMLERİ sayfası haricinde 01 sayfasından veri alıyor diğerlerinde almıyor. Dosya aynı dosya yusuf bey size zahmet olmazsa siz adapte edip gönderebilirmisiniz?

Size de zahmet oldu. Çok teşekkürler.

 

[YUSUF44]

Dosya eklemek için mesaj penceresinin altındaki gelişmiş moda dön düğmesine basmalısınız.

Şimdi tekrar denedim, sorunsuz çalışıyor.

 

[incsoft]

Peki hocam hücreleri formül değilde değer olarak nasıl yapıştırabiliriz? Diğerini çözdüm.

 

[YUSUF44]

Örnek dosyanızda zaten formül yok. Asıl dosyanız formüllüyse ve değer olarak yapıştırmak istiyorsanız aşağıdaki gibi olabilirdi ama hücre birleştirmeleri nedeniyle makro değer yapıştırmıyor:

Sub rapor()
uyarı = MsgBox("KALİTE PROBLEMLERİ sayfasındaki eski veriler silinsin mi?", vbYesNo)
Set s1 = Sheets("KALİTE PROBLEMLERİ")
If uyarı = vbYes Then
    eski = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "B").End(3).Row)
    s1.Range("B3:AK" & eski) = ""
End If
For sayfa = 1 To Sheets.Count
    If Sheets(sayfa).Name <> s1.Name Then
        yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
        Sheets(sayfa).[B14:AK26].Copy: s1.Cells(yeni, "B").PasteSpecial Paste:=xlPasteValues
    End If
    son = s1.Cells(Rows.Count, "B").End(3).Row + 1
    s1.Range("B" & son & ":AK" & son).Borders.Weight = xlThick
    s1.Range("B2:AK150").Interior.Color = xlNone
Next
End Sub

Bunun yerine hücre hücre aktarma seçilebilir:

Sub rapor()
uyarı = MsgBox("KALİTE PROBLEMLERİ sayfasındaki eski veriler silinsin mi?", vbYesNo)
Set s1 = Sheets("KALİTE PROBLEMLERİ")
If uyarı = vbYes Then
    eski = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "B").End(3).Row)
    s1.Range("B3:AK" & eski) = ""
End If
For sayfa = 1 To Sheets.Count
    If Sheets(sayfa).Name <> s1.Name Then
        For i = 14 To 26
            yeni = s1.Cells(Rows.Count, "B").End(3).Row + 1
            s1.Range("B" & yeni) = Sheets(sayfa).Range("B" & i)
            s1.Range("E" & yeni) = Sheets(sayfa).Range("E" & i)
            s1.Range("J" & yeni) = Sheets(sayfa).Range("J" & i)
            s1.Range("AE" & yeni) = Sheets(sayfa).Range("AE" & i)
        Next
    End If
    son = s1.Cells(Rows.Count, "B").End(3).Row + 1
    s1.Range("B" & son & ":AK" & son).Borders.Weight = xlThick
    s1.Range("B2:AK150").Interior.Color = xlNone
Next
End Sub