makro ile pdf formatında raporlama

K

kiran67

Katılım
11 Aralık 2020
Mesajlar
24
Excel Vers. ve Dili
excel 2010
Merhaba excelde hatalı kayıtlar için koşullu biçimlendirme yaptım. Sadece bu renkli hücreleri satırıyla birlikte rapor yada pdf şeklinde alabilir miyim. Makro hakkında hiç bir fikrim yok. A1 ile AB6000 aralığında veri var. A-Sicil B-Ad C-soyad D- Tarih ve S hücresi ile AB arasında da veriler var bu hücre aralıklarını almak istiyorum. Yada hepsini alsın farketmez ama satır olarak sadece renkli hücreleri almasını istiyorum. Şimdiden teşekkürler.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,272
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Dosyanızın 50 satırlık örnek halini paylaşırsanız yardım almanız kolaylaşır.
 
K

kiran67

Katılım
11 Aralık 2020
Mesajlar
24
Excel Vers. ve Dili
excel 2010
Bulabilseydim kodları değiştirmeyi denerdim ama örnek bulamadım. En azından daha önce yapılmış varsa gönderemez misiniz. Onun üzerinden birşeyler yapmaya çalışayım. Sarı dolgu da olur onun renk kodu 6'ymış sanırım daha kolay olması açısından renkleri sarı yapabilirim.
 
H

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
12,406
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Altın Üyelik Bitiş Tarihi
∞
Google Sheets'de script ile, Excel'de seçilen bir alanın PDF'e dönüştürülmesiyle ilgili bir çalışmam var. İsterseniz, inceleyebilirsiniz....

Kod anlatılmaz, yazılır...: Google Script'le PDF Hazırlama....

Google Sheets ve scripting için Türkçe kaynak... bazı özel konularda Excel VBA örnekleri
excelhaluk.blogspot.com excelhaluk.blogspot.com

.
 
K

kiran67

Katılım
11 Aralık 2020
Mesajlar
24
Excel Vers. ve Dili
excel 2010
Haluk' Alıntı:
Google Sheets'de script ile, Excel'de seçilen bir alanın PDF'e dönüştürülmesiyle ilgili bir çalışmam var. İsterseniz, inceleyebilirsiniz....

Kod anlatılmaz, yazılır...: Google Script'le PDF Hazırlama....

Google Sheets ve scripting için Türkçe kaynak... bazı özel konularda Excel VBA örnekleri
excelhaluk.blogspot.com excelhaluk.blogspot.com

.
Genişletmek için tıkla ...
ben aralarda kalan renkli sütunların ayrıştırılmasını istiyorum ama pdf olmasa da olur başka bir sayfaya. Hatalı kayıtların tek bir yerde toplanmasını istiyorum.
 
K

kiran67

Katılım
11 Aralık 2020
Mesajlar
24
Excel Vers. ve Dili
excel 2010
Private Sub Kontrol_Click()

Sheets("KONTROL").Range("A2:E30000").ClearContents




s = 2
For k = 4 To Cells(2, 46) + 3
For t = 9 To Cells(2, 47) + 8

Worksheets("kontrol").Cells(s, 1) = Cells(k, 2)

Worksheets("kontrol").Cells(s, 2) = Cells(k, 3)


Worksheets("kontrol").Cells(s, 4) = Cells(2, t)

Worksheets("kontrol").Cells(s, 5) = Cells(k, t) 'puantaj1

s = s + 1 'satır atla



Next






Next
End Sub

Bu maktoyu hızlandırma imkanımız var mı en azından ona yardımcı olur musunuz? isim ve tarihlerin kesiştiği (satır ve sütun) yerden veri çekip başka sayfaya yazıyor. Fakat veri çektiği yerde düşeyara lı formüller var bütün hücrelerde. 250-300 satır bu da makroyu yoruyor.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,272
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Hız olarak avantaj sağlayacaktır.

LİSTE isimli sayfanızda başlıkları aşağıdaki gibi düzenledikten sonra sayfa ayarını yapın.

223455


Sonra kodu çalıştırınız.

C++: 
Option Explicit

Sub Renkli_Satirlari_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant, Hucre As Range, Onay As Byte
    Dim X As Long, Son As Long, Say As Long, Kontrol As Boolean, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
   
    Set S1 = Sheets("KONTROL")
    Set S2 = Sheets("LİSTE")
   
    S2.Range("A2:N" & S2.Rows.Count).Clear
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 1 Then
        MsgBox "Sayfada kontrol edilecek veri bulunamadı!", vbCritical
        Exit Sub
    End If
   
    If Son = 2 Then Son = 3
   
    Veri = S1.Range("A2:AB" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 13)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Each Hucre In S1.Range("S" & X + 1 & ":AB" & X + 1)
            If Not IsError(Hucre) Then
                If Hucre.DisplayFormat.Interior.ColorIndex <> -4142 Then
                    Kontrol = True
                    Exit For
                End If
            End If
        Next
           
        If Kontrol = True Then
            Say = Say + 1
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
            Liste(Say, 5) = Veri(X, 19)
            Liste(Say, 6) = Veri(X, 20)
            Liste(Say, 7) = Veri(X, 21)
            Liste(Say, 8) = Veri(X, 22)
            Liste(Say, 9) = Veri(X, 24)
            Liste(Say, 10) = Veri(X, 25)
            Liste(Say, 11) = Veri(X, 26)
            Liste(Say, 12) = Veri(X, 27)
            Liste(Say, 13) = Veri(X, 28)
        End If
        Kontrol = False
    Next

    If Say > 0 Then
        With S2.Range("A2").Resize(Say, 13)
            .Value = Liste
            .Borders.LineStyle = 1
        End With
       
        S2.Columns.AutoFit
       
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
       
        MsgBox "Renkli verilerin aktarımı tamamlanmıştır" & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
       
        Onay = MsgBox("Hazırlanan raporun PDF olarak kayıt edilmesini ister misiniz?", vbExclamation + vbYesNo + vbDefaultButton2)
        If Onay = vbNo Then
            MsgBox "PDF olarak kayıt etme işlemi isteğiniz üzerine iptal edilmiştir!", vbExclamation
        Else
            S2.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=ThisWorkbook.Path & Application.PathSeparator & "Rapor.pdf", _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
            MsgBox "PDF dosyanız aşağıdaki isimle kayıt edilmiştir." & vbLf & vbLf & _
                   ThisWorkbook.Path & Application.PathSeparator & "Rapor.pdf"
        End If
    Else
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
       
        MsgBox "Renkli hücre bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
End Sub
 
K

kiran67

Katılım
11 Aralık 2020
Mesajlar
24
Excel Vers. ve Dili
excel 2010
Korhan Ayhan' Alıntı:
Deneyiniz.

Hız olarak avantaj sağlayacaktır.

LİSTE isimli sayfanızda başlıkları aşağıdaki gibi düzenledikten sonra sayfa ayarını yapın.

Ekli dosyayı görüntüle 223455


Sonra kodu çalıştırınız.

C++: 
Option Explicit

Sub Renkli_Satirlari_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant, Hucre As Range, Onay As Byte
    Dim X As Long, Son As Long, Say As Long, Kontrol As Boolean, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
  
    Set S1 = Sheets("KONTROL")
    Set S2 = Sheets("LİSTE")
  
    S2.Range("A2:N" & S2.Rows.Count).Clear
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 1 Then
        MsgBox "Sayfada kontrol edilecek veri bulunamadı!", vbCritical
        Exit Sub
    End If
  
    If Son = 2 Then Son = 3
  
    Veri = S1.Range("A2:AB" & Son).Value
  
    ReDim Liste(1 To Son, 1 To 13)
  
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Each Hucre In S1.Range("S" & X + 1 & ":AB" & X + 1)
            If Not IsError(Hucre) Then
                If Hucre.DisplayFormat.Interior.ColorIndex <> -4142 Then
                    Kontrol = True
                    Exit For
                End If
            End If
        Next
          
        If Kontrol = True Then
            Say = Say + 1
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
            Liste(Say, 5) = Veri(X, 19)
            Liste(Say, 6) = Veri(X, 20)
            Liste(Say, 7) = Veri(X, 21)
            Liste(Say, 8) = Veri(X, 22)
            Liste(Say, 9) = Veri(X, 24)
            Liste(Say, 10) = Veri(X, 25)
            Liste(Say, 11) = Veri(X, 26)
            Liste(Say, 12) = Veri(X, 27)
            Liste(Say, 13) = Veri(X, 28)
        End If
        Kontrol = False
    Next

    If Say > 0 Then
        With S2.Range("A2").Resize(Say, 13)
            .Value = Liste
            .Borders.LineStyle = 1
        End With
      
        S2.Columns.AutoFit
      
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
      
        MsgBox "Renkli verilerin aktarımı tamamlanmıştır" & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
      
        Onay = MsgBox("Hazırlanan raporun PDF olarak kayıt edilmesini ister misiniz?", vbExclamation + vbYesNo + vbDefaultButton2)
        If Onay = vbNo Then
            MsgBox "PDF olarak kayıt etme işlemi isteğiniz üzerine iptal edilmiştir!", vbExclamation
        Else
            S2.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=ThisWorkbook.Path & Application.PathSeparator & "Rapor.pdf", _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
            MsgBox "PDF dosyanız aşağıdaki isimle kayıt edilmiştir." & vbLf & vbLf & _
                   ThisWorkbook.Path & Application.PathSeparator & "Rapor.pdf"
        End If
    Else
        Application.Calculation = -4105
        Application.ScreenUpdating = 1
      
        MsgBox "Renkli hücre bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
End Sub
Genişletmek için tıkla ...
Çok teşekkür ederim. Çalıştı ve acayip hızlı süper :) Formüller bir şekilde yapılıyor ama makroyu anlamak çok zor geliyor bana. Elinize kolunuza sağlık.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,272
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Makro bitiminde ekran hareketlerini aktif yapan satırdaki değeri eski haliyle bırakmışım. Kodu revize ettim.

Son halini kullanınız.
 
B

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
184
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
ThisWorkbook.Path & Application.PathSeparator & "Rapor.pdf"

MERHABA, ben pdf olarak toplu şekilde kaydediyorum ancak. pdf ismini kaydederken ilgili sütunda yazan ünvan şeklinde kaydetmek istiyorum bunun için ne yapabilirim
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,272
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kullandığınız kodu paylaşırsanız ona göre çözüm önerilebilir.
 
B

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
184
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Teşekkür ederim Korhan Bey aşağıda ki şekilde hallettim.

Filename:=ThisWorkbook.Path & Application.PathSeparator & S1.Range("C3") & " DEĞERLENDİRME " & ".pdf", _
 
B

bjk55

Altın Üye
Katılım
29 Mart 2010
Mesajlar
184
Excel Vers. ve Dili
TÜRKÇE - MİCROSOFT OFFİCE PROFESSİONAL PLUS 2021
Altın Üyelik Bitiş Tarihi
05-03-2036
Aşağıdaki şekilde bir makro var ben pdf olarak değilde jpg olarak kaydetmesini istiyorum Bunu nasıl yapabilirim




Sub Seri_Yazdir_PDF()
Dim WF As WorksheetFunction, S1 As Worksheet, S2 As Worksheet
Dim Baslangic_No As Variant, Bitis_No As Variant, X As Long

Set S1 = Sheets("ŞİRKET DEĞERLENDİRME")
Set S2 = Sheets("ŞİRKET")
Set WF = WorksheetFunction

Baslangic_No = InputBox("Lütfen yazdırmak istediğiniz başlangıç numarasını giriniz...", , WF.Min(1, Sheets("ŞİRKET").Range("B:B")))
Bitis_No = InputBox("Lütfen yazdırmak istediğiniz bitiş numarasını giriniz...", , WF.Max(Sheets("ŞİRKET").Range("B:B")))

If Baslangic_No = "" Or Bitis_No = "" Or Not IsNumeric(Baslangic_No) Or Not IsNumeric(Bitis_No) Then
MsgBox "Lütfen başlangıç ve bitiş numaralarını eksiksiz ve numerik değer giriniz!", vbCritical
Exit Sub
End If

If Baslangic_No > 0 And Bitis_No > 0 Then
For X = Baslangic_No To Bitis_No
S1.Range("H3") = X
S1.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & Application.PathSeparator & S1.Range("C3") & " DEĞERLENDİRME " & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Next

MsgBox "Verileriniz PDF olarak kayıt edilmiştir.", vbInformation
End If

Set S1 = Nothing
Set S2 = Nothing
Set WF
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst