rapor oluşturma

[sinemomec]

userformda excel'e raporla komutu ile GELENEVRAK excel sayfasındaki tüm verileri yeni bir excel dosyası olarak raporlayabilirmiyim?

 

[sinemomec]

Yardımlarınızı bekliyorum

 

[sinemomec]

gelenevrak sayfasındaki a hücresi ile h hücresi arasında kayıtlı olan verileri seçip yeni bir excel sayfasına kayıt yapmasını istiyorum.
yardımlarınızı bekliyorum.

 

[sinemomec]

yardımınızı bekliyorum

 

[kakara]

buyuk bır ıhtımalle ustadlar sızden örnek bır çalışma dosyası beklıyor

 

[YUSUF44]

Sayın kakara'nın da belirttiği gibi örnek dosyasız taleplerin çözümü sıkıntılı oluyor. Hazırlanan makronun sizin dosyanıza ne kadar uyacağını bilmiyoruz çünkü.

Aşağıdaki makroyu deneyin:

Sub sayfakaydet()

Sayfa_Adı = ActiveSheet.Name

Klasor = ActiveWorkbook.Path & Application.PathSeparator

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
For Each sayfa In Worksheets
    If sayfa.Name = Sayfa_Adı Then
        For i = Len(ThisWorkbook.Name) To 1 Step -1
            If Mid(ThisWorkbook.Name, i, 1) = "." Then
                Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
                Exit For
            End If
        Next
        For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
            If Mid(Dosya.Name, 1, Len(Dosya_adi)) = Dosya_adi Then
                sat = sat + 1
                a = ds.FileExists(Klasor & Dosya_adi & sat) ' & Uzanti)
                If a = True Then
                Else
                    son = 1
                    Exit For
                End If
            End If
        Next
        If son = 0 Then
            sat = sat + 1
        End If
        sayfa.Copy
        deger = Dosya_adi & sat & Uzanti
        ActiveSheet.DrawingObjects.Delete
        For Each component In ActiveWorkbook.VBProject.VBComponents
            If component.Type <> 100 Then
                ActiveWorkbook.VBProject.VBComponents.Remove component
            Else
                Set modul = component.CodeModule
                modul.DeleteLines 1, modul.CountOfLines
            End If
        Next
        Dim wb As Workbook
        Set wb = ActiveWorkbook
        Application.DisplayAlerts = False
            With wb
                .SaveAs Klasor & deger
                .Close SaveChanges:=False
            End With
        Application.DisplayAlerts = True

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
Next
End Sub

 

[sinemomec]

örnek dosyası yükledim userform üzerinden gelenevrak kısmında excele raporla dediğim zaman gelenevrak excel sayfasındaki veriyi yeni bir excel dosyası olarak raporlamasını ve masaüstüne kaydetmesini istiyorum ancak başaramadım.
şimdiden teşekkür ederim.

İndir EVRAK KAYIT5

Dosyayı indir EVRAK KAYIT5

dosya.co

 

[YUSUF44]

Yukarda verdiğim kodları sizin dosyanıza uyarlamaya çalıştım. Aşağıdaki kodları Excele raporla düğmesine ekleyin:

Dim oWSHShell As Object

Set oWSHShell = CreateObject("WScript.Shell")
Klasor = oWSHShell.SpecialFolders("Desktop") & Application.PathSeparator
Set oWSHShell = Nothing

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
For Each sayfa In Worksheets
    If sayfa.Name = "GELENEVRAK" Then
        For i = Len(ThisWorkbook.Name) To 1 Step -1
            If Mid(ThisWorkbook.Name, i, 1) = "." Then
                Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
                Exit For
            End If
        Next
        For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
            If Mid(Dosya.Name, 1, Len(Dosya_adi)) = Dosya_adi Then
                sat = sat + 1
                a = ds.FileExists(Klasor & Dosya_adi & sat) ' & Uzanti)
                If a = True Then
                Else
                    son = 1
                    Exit For
                End If
            End If
        Next
        If son = 0 Then
            sat = sat + 1
        End If
        sayfa.Copy
        deger = Dosya_adi & sat & Uzanti
        ActiveSheet.DrawingObjects.Delete
        For Each component In ActiveWorkbook.VBProject.VBComponents
            If component.Type <> 100 Then
                ActiveWorkbook.VBProject.VBComponents.Remove component
            Else
                Set modul = component.CodeModule
                modul.DeleteLines 1, modul.CountOfLines
            End If
        Next
        Dim wb As Workbook
        Set wb = ActiveWorkbook
        Application.DisplayAlerts = False
            With wb
                .SaveAs Klasor & deger
                .Close SaveChanges:=False
            End With
        Application.DisplayAlerts = True

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
Next

 

[sinemomec]

teşekkür ederim

 

[sinemomec]

peki bir şey sorucam her raporla dediğim zaman dosya adını
gelenevrak rapor1
gelenevrak rapor2
gelenevrak rapor3 gibi ilerletebilirmiyim.

 

[YUSUF44]

O şekilde yapamadım ama dosya adının sonuna tarih ve saat ekledim. İsterseniz aşağıdaki gibi kullanabilirsiniz:

Private Sub cmdexcelrapor_Click()
Dim oWSHShell As Object

Set oWSHShell = CreateObject("WScript.Shell")
Klasor = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
For Each sayfa In Worksheets
    If sayfa.Name = "GELENEVRAK" Then
        For i = Len(ThisWorkbook.Name) To 1 Step -1
            If Mid(ThisWorkbook.Name, i, 1) = "." Then
                Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
                Exit For
            End If
        Next
        sayfa.Copy
        deger = Dosya_adi & " " & Format(Now, "yyyymmdddd hhmmss") & Uzanti
        ActiveSheet.DrawingObjects.Delete
        For Each component In ActiveWorkbook.VBProject.VBComponents
            If component.Type <> 100 Then
                ActiveWorkbook.VBProject.VBComponents.Remove component
            Else
                Set modul = component.CodeModule
                modul.DeleteLines 1, modul.CountOfLines
            End If
        Next
        Dim wb As Workbook
        Set wb = ActiveWorkbook
        Application.DisplayAlerts = False
            With wb
                .SaveAs Klasor & Application.PathSeparator & deger
                .Close SaveChanges:=False
            End With
        Application.DisplayAlerts = True

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
Next
End Sub

 

[sinemomec]

teşekkür ederim elinize sağlık.....

 

[sinemomec]

sayfa.Copy burada hata veriyor

 

[sinemomec]

hata sebebi sayfayı gizlediğim zaman oluşuyor sayfa gizli olmadığı zaman sıkıntı yok

 

[sinemomec]

bir şey soracağım peki bu sayfayı tekrar pdf formatına dönüştürebilirmiyim

 

[YUSUF44]

bir şey soracağım peki bu sayfayı tekrar pdf formatına dönüştürebilirmiyim

"Tekrar" derken daha önce "pdf" miydi?

 

[sinemomec]

hayır şimdi excel rapor aldık ya bunu pdf yapılabilir mi? userform üzerinden

 

[YUSUF44]

Userforma bir düğme daha ekleyin ve o düğmeye aşağıdaki kodları ekleyin. Öncesinde GELENEVRAK sayfasının yazdırma ayarını yapmanız gerekir. Şu anda bir sayfaya sığdırmıyor çünkü:

Dim oWSHShell As Object

Set oWSHShell = CreateObject("WScript.Shell")
Klasor = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing
Sheets("GELENEVRAK").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Klasor & "\GELEN EVRAK KAYIT " & Format(Now, "yyyymmdddd hhmmss") & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False

 

[sinemomec]

hata verdi

 

[YUSUF44]

Allah rızası için bize müneccimmişiz gibi davranmayın. Ben kodu deneyerek gönderdim, herhangi bir hata vermedi. Ne hata verdiğini nerden bilebilirim?