• DİKKAT

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

Belli Sütunları Makro İle Ayrı Sayfada Raporlamak

F

figutive

Katılım
20 Haziran 2007
Mesajlar
19
Excel Vers. ve Dili
excel 2007
Merhabalar

Ekteki dosyada işaretlenmiş olan sütunlardaki verilerden, her satır için bir excel sayfasına alt alta bazı verilerin raporlanması gerekiyor.

Yani satırdaki verileri rapora çevirmek istiyorum ancak bu konuda gercekten hiç bir fikrim yok yardımcı olursanız sevinirim.

Şimdiden teşekkürler
 

Ekli dosyalar

Merhaba;

Makroda sayfa oluştururken ilk önce L sütunun kontrol ediliyor. L sütununda "Sayfa Olarak Oluşturuldu" ibaresi yoksa sayfa oluşturuluyor. L sütunu sayfa oluşturmak için yardımcı sütun olarak kullanılmıştır. Sayfa oluşturulduktan sonra aktif olan sayfa ismini A sütunundan almaktadır. Bilginize.

Kullanılan kod
Kod: 
Option Explicit
Sub Her_Satır_İçin_Rapor_Sayfası()
Dim U As Long, Satır As Long, S1 As Worksheet, S2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    
    Set S1 = Sheets("GRC TEMPLATE")
    Set S2 = Sheets("ÇALIŞMA KAĞIDI")
    
    For U = 10 To S1.[A65536].End(3).Row
        If Len(S1.Cells(U, "A")) > 31 Then GoTo Hata:
        If S1.Cells(U, "L") <> "Sayfa Olarak Oluşturuldu" Then
            S2.Copy After:=Sheets(Worksheets.Count)
            On Error GoTo Hata2:
            ActiveSheet.Name = S1.Cells(U, "A")
            Range("B3").ClearContents
            Range("E3").ClearContents
            Range("C8:E24").ClearContents
            Range("B3") = S1.Cells(U, "A")
            Range("C8") = S1.Cells(U, "B")
            Range("C10") = S1.Cells(U, "C")
            Range("C12") = S1.Cells(U, "D")
            Range("C14") = S1.Cells(U, "E")
            Range("C16") = S1.Cells(U, "F")
            Range("C18") = S1.Cells(U, "G")
            Range("C20") = S1.Cells(U, "H")
            Range("C22") = S1.Cells(U, "I")
            Range("C24") = S1.Cells(U, "J")
            Range("E3") = S1.Cells(U, "K")
            S1.Cells(U, "L") = "Sayfa Olarak Oluşturuldu"
        End If
    Next
Hata:
    MsgBox S1.Cells(U, "A") & " Sayfasının karakter sayısı uzundur" & vbCrLf & "Bu yüzden sayfa oluşturulamadı."
Hata2:
    MsgBox S1.Cells(U, "A") & " Sayfası daha önce oluşturulmuştur." & vbCrLf & "Bu yüzden sayfa oluşturulamadı."
    ActiveSheet.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Sayın usubaykan

Emeğiniz için teşekkürler. Yanlız bir kaç noktada sorun var.

1- çalışmada GRC Templateden verileri alıp Çalışma kağıdına rapor oluşturması gerekiyor.
2- Sadece 1 satır için rapor oluşturmak deiğilde altta kaç satır varsa hepsi için rapor oluşturmak istiyorum.

Selamlar
 
Merhaba,

İstediğiniz formatta bir örnek dosya ekler misiniz?
 
ekteki dosyanın çözümü benim sorunumada yardımcı olacak.

ben birde oluşturulan yeni sayfaların isimlerininde, exceldeki o satırdaki hücreden almasını istiyorum
 
Merhaba,
Aşağıdaki kodu dener misiniz?
Kullanılan kod;
Kod: 
Option Explicit
Sub Düzenle()
Dim U As Long, S As Long, Son_Satır As Long, S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Bul As Range
Set S1 = Sheets("GRC TEMPLATE")
Set S2 = Sheets("ÇALIŞMA KAĞIDI")
Set S3 = Sheets("ÖRNEK SONUC TABLOSU")
Application.ScreenUpdating = False
    For U = 10 To S1.[A65536].End(3).Row ' GRC TEMPLATE sayfasının A sütununda bulunan satır sayısı kadar ÇALIŞMA KAĞIDIndan örneği kopyalıyor
        Son_Satır = S3.[B65536].End(3).Row
        S2.Range("B3:E25").Copy
        S3.Range("B" & Son_Satır + 3 & ":F" & Son_Satır + 3).PasteSpecial
        Set Bul = Range("B" & Son_Satır + 8 & ":E" & Son_Satır + 8).Find(What:="Testi Yapan Denetçi:", LookAt:=xlWhole)
        If Not Bul Is Nothing Then
            Cells(Bul.Row - 5, "B") = S1.Cells(U, "A")
            Cells(Bul.Row, "C") = S1.Cells(U, "B")
            Cells(Bul.Row + 2, "C") = S1.Cells(U, "C")
            Cells(Bul.Row + 4, "C") = S1.Cells(U, "D")
            Cells(Bul.Row + 6, "C") = S1.Cells(U, "E")
            Cells(Bul.Row + 8, "C") = S1.Cells(U, "F")
            Cells(Bul.Row + 10, "C") = S1.Cells(U, "G")
            Cells(Bul.Row + 12, "C") = S1.Cells(U, "H")
            Cells(Bul.Row + 14, "C") = S1.Cells(U, "I")
            Cells(Bul.Row + 16, "C") = S1.Cells(U, "J")
            Cells(Bul.Row - 5, "E") = S1.Cells(U, "K")
        Set Bul = Range("B:E").FindNext(Bul)
        End If
    Next
   Set Bul = Nothing
    Application.CutCopyMode = xlCopy = False
    Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır."
End Sub
 
Son düzenleme:
Hocam ellerinize emeğinize sağlık

Çok güzel bir çalışma olmuş.

Şöyle bir kaç ekleme yapabilir miyiz

rapor tablosunu örnek dosya yerine

"ÇALIŞMA KAĞIDI RAPORLAR" diye bir sayfaya oluştursak,

Oluşan rapor tablosunu print ekranına her rapor 1 sayfaya gelecek şekilde hazırlasak,

ve Macro için sayfaya bir kısayol tuşu oluşturup ordan çalıştırsak,

Bu haliyle işimi fazlasıyla görüyor ancak şu 3 düzeltmede olursa mükemmel bir çalışma olmuş olacak

SELAMLAR
 
figutive' Alıntı:
Hocam ellerinize emeğinize sağlık

Çok güzel bir çalışma olmuş.

Şöyle bir kaç ekleme yapabilir miyiz

rapor tablosunu örnek dosya yerine

"ÇALIŞMA KAĞIDI RAPORLAR" diye bir sayfaya oluştursak,

Oluşan rapor tablosunu print ekranına her rapor 1 sayfaya gelecek şekilde hazırlasak,

ve Macro için sayfaya bir kısayol tuşu oluşturup ordan çalıştırsak,

Bu haliyle işimi fazlasıyla görüyor ancak şu 3 düzeltmede olursa mükemmel bir çalışma olmuş olacak

SELAMLAR
Genişletmek için tıkla ...

Merhaba,

Kullanılan kod;
Kod: 
Option Explicit
Sub Düzenle()
Dim U As Long, S As Long, Son_Satır As Long, S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Bul As Range, ONAY
ONAY = MsgBox("İşlem başladığında GRC TEMPLATE sayfasında A sütununda bulunan satır kadar çıktı alınacaktır onaylıyor musunuz?", vbCritical + vbYesNo)
If ONAY = vbYes Then
Set S1 = Sheets("GRC TEMPLATE")
Set S2 = Sheets("ÇALIŞMA KAĞIDI")
Set S3 = Sheets("ÇALIŞMA KAĞIDI RAPORLAR")
Application.ScreenUpdating = False
    For U = 10 To S1.[A65536].End(3).Row ' GRC TEMPLATE sayfasının A sütununda bulunan satır sayısı kadar ÇALIŞMA KAĞIDIndan örneği kopyalıyor
        Son_Satır = S3.[B65536].End(3).Row
        S2.Range("B3:E25").Copy
        S3.Range("B" & Son_Satır + 3 & ":F" & Son_Satır + 3).PasteSpecial
        Set Bul = Range("B" & Son_Satır + 8 & ":E" & Son_Satır + 8).Find(What:="Testi Yapan Denetçi:", LookAt:=xlWhole)
        If Not Bul Is Nothing Then
            S3.Cells(Bul.Row - 5, "B") = S1.Cells(U, "A")
            S3.Cells(Bul.Row, "C") = S1.Cells(U, "B")
            S3.Cells(Bul.Row + 2, "C") = S1.Cells(U, "C")
            S3.Cells(Bul.Row + 4, "C") = S1.Cells(U, "D")
            S3.Cells(Bul.Row + 6, "C") = S1.Cells(U, "E")
            S3.Cells(Bul.Row + 8, "C") = S1.Cells(U, "F")
            S3.Cells(Bul.Row + 10, "C") = S1.Cells(U, "G")
            S3.Cells(Bul.Row + 12, "C") = S1.Cells(U, "H")
            S3.Cells(Bul.Row + 14, "C") = S1.Cells(U, "I")
            S3.Cells(Bul.Row + 16, "C") = S1.Cells(U, "J")
            S3.Cells(Bul.Row - 5, "E") = S1.Cells(U, "K")
            
            Application.CutCopyMode = False
            Son_Satır = Son_Satır + 25
            If Son_Satır <= 26 Then
                        S3.PageSetup.PrintArea = "$B$4:$E$" & Son_Satır
                        'S3.PrintOut Copies:=1 ' print almanız için kullanılmıştır. print almak istiyorsanız başındaki "'" işaretini kaldırın.
            Else
                        S3.PageSetup.PrintArea = "$B$" & Son_Satır - 22 & ":$E$" & Son_Satır
                        'S3.PrintOut Copies:=1 ' print almanız için kullanılmıştır. print almak istiyorsanız başındaki "'" işaretini kaldırın.
                        Son_Satır = 0
                    End If
            End If
    Next
   Set Bul = Nothing
   S3.PageSetup.PrintArea = ""
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır."
End If
End Sub
Ekli dosyayı inceler misiniz?
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst