rapor oluşturma

[sinemomec]

sor = MsgBox("GELEN EVRAK LİSTESİ ARŞİVLEME YAPILSINMI?", vbYesNoCancel + vbInformation, "BİLDİRİ")
If sor = vbNo Then Exit Sub

msjbax ta sordurdum arşivleme yapılsınmı diye
yes/ no yaptım
yes dedim tekrar bir bildiri ve son onay vermesini "mesaj" içermesini istiyorum

 

[YUSUF44]

NE istediğinizi anlamadım. NE istediğinizi daha açık bir şekilde örnekleyerek anlatın lütfen.

 

[sinemomec]

sor = MsgBox("GELEN EVRAK LİSTESİ ARŞİVLEME YAPILSINMI?", vbYesNoCancel + vbInformation, "BİLDİRİ")
If sor = vbNo Then Exit Sub

bu yaptığım kodda msjbax arşivelensinmi diye soruyor yes/no yapıyorum.
yes yaptığım zaman hemen işlemi yapıyor.
ben yes dedikten sonra son kez bir onay almasını ve bana mesaj vermesini ve işlemi bu şekilde yapmasını istiyorum

inşallah anlatabilmişimdir.

 

[YUSUF44]

Bu satırları bu satırların altına bir daha ekleyip, mesajı istediğiniz gibi ayarlayarak deneyin.

 

[sinemomec]

Private Sub cmdexcelrapor_Click()
Dim oWSHShell As Object
sor = MsgBox("GELEN EVRAK LİSTESİ EXCEL'e RAPORLANSINMI ?", vbYesNoCancel + vbInformation, "BİLDİRİ")
If sor = vbNo Then Exit Sub
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

masaüstüne indirmeyi gerçekleştiriyor. ancak bu dosyası nasıl açmak istersiniz diye bir uyarı veriyor ve excel olarak açmıyor

 

[sinemomec]

bilinmeyen dosya türünde yapıyor hatam nedir

 

[YUSUF44]

Şimdi denedim, excel dosyası olarak kaydetti.

 

[sinemomec]

İndir EVRAK KAYIT

Dosyayı indir EVRAK KAYIT

dosya.co

incelerseniz sevinirim.

 

[sinemomec]

dosyayı d koydum ve bir kısayol yaptım etkilermi bilemedim.

 

[YUSUF44]

deger = Dosya_adi & " " & Format(Now, "yyyymmdddd hhmmss") & Uzanti

satırını

deger = Dosya_adi & " " & Format(Now, "yyyymmdddd hhmmss") & ".xlsx"

olarak değiştirip, deneyin.

 

[sinemomec]

düzeldi teşekkür ederim.