Makro ile Dialog Penceresi bulmak

[buyocan]

İyi günler forumda aramama rağmen bir sürü gialog penceresi buldum ama hiç biri benim aradığım değil.
Benim sorum csv olarak kaydettiğimde ekrana gelen resimdeki dialog penceresine makro ile nasil bulup evet derim
şimdiden yardım eden herkese hayırlı günler.

http://dosya.co/g799prxh7ur9/Resim_2A.jpg.html

 

[Asri]

Aşağıdaki kodda buton işlemleri yok. Sanırım istediğiniz şey bu.

Bu kod aktif olan çalışma kitabındaki bütün sayfaları, hiç bir şey sormadan csv olarak kaydeder.

Dosya adları,

dosyadi_Sayfa1.csv
dosyadi_Sayfa2.csv

CSV içeriği,
sdasfafadfdf;dsfadsf;fsdfa;dfsdf;fdsfsd;sdf;dsfsd;sdfs; 1.320,34

Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven

' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

' Save the file in current director
OutputPath = ThisWorkbook.Path


If OutputPath <> "" Then
Application.Calculation = xlCalculationManual

' save for each sheet
For Each Sheet In Sheets

    
    For I = Len(ActiveWorkbook.Name) To 1 Step -1
     If Mid(ActiveWorkbook.Name, I, 1) = "." Then Exit For
    Next I
    dosyaadi = Mid(ActiveWorkbook.Name, 1, I - 1)
    dosyaadi = ActiveWorkbook.Path & "\" & dosyaadi & ".csv"
   'MsgBox dosyaadi
    sayfaadi = Sheet.Name
    dosyaadi = Mid(ActiveWorkbook.Name, 1, I - 1)
    dosyaadi = ActiveWorkbook.Path & "\" & dosyaadi & "_" & sayfaadi & ".csv"
    Sheet.Copy
    
    
    ActiveWorkbook.SaveAs FileName:=dosyaadi, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
    ActiveWorkbook.Close SaveChanges:=False
Next

Application.Calculation = xlCalculationAutomatic
  Application.DisplayAlerts = False
ActiveWorkbook.Close
  Application.DisplayAlerts = True
End If

Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

Exit Sub

Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
        "Source: " & Err.Source & " " & vbCrLf & _
        "Number: " & Err.Number & " " & vbCrLf & _
        "Description: " & Err.Description & " " & vbCrLf

GoTo Finally
End Sub

 

[buyocan]

Tam istediğim şekilde elinize sağlık.

 

[buyocan]

Tekrar merhaba tek sayfa olan dosyamda sorun yok ama kapak gibi değişik sayfalarımın olduğu dosyamda sorun oldu. Şöyle ki tüm excel sayfalarımı çevirme yapıyor. Sadece belirttiğim sayfa olacak şekilde nasil yapabilirim yardım edenlere şimdiden teşekkürler

 

[Asri]

Tekrar merhaba tek sayfa olan dosyamda sorun yok ama kapak gibi değişik sayfalarımın olduğu dosyamda sorun oldu. Şöyle ki tüm excel sayfalarımı çevirme yapıyor. Sadece belirttiğim sayfa olacak şekilde nasil yapabilirim yardım edenlere şimdiden teşekkürler

Aktif olan sayfayı CSV olarak kaydeder.
Excel kitabını kapatmaz.

Public Sub SaveAllSheetsAsCSV()
'On Error GoTo Heaven

' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

' Save the file in current director
OutputPath = ThisWorkbook.Path


If OutputPath <> "" Then
Application.Calculation = xlCalculationManual

' save for each sheet
   
    For I = Len(ActiveWorkbook.Name) To 1 Step -1
     If Mid(ActiveWorkbook.Name, I, 1) = "." Then Exit For
    Next I
    dosyaadi = Mid(ActiveWorkbook.Name, 1, I - 1)
    dosyaadi = ActiveWorkbook.Path & "\" & dosyaadi & ".csv"
   'MsgBox dosyaadi
    sayfaadi = ActiveSheet.Name
    dosyaadi = Mid(ActiveWorkbook.Name, 1, I - 1)
    dosyaadi = ActiveWorkbook.Path & "\" & dosyaadi & "_" & sayfaadi & ".csv"
    ActiveSheet.Copy
    
    
    ActiveWorkbook.SaveAs Filename:=dosyaadi, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
    ActiveWorkbook.Close SaveChanges:=False

Application.Calculation = xlCalculationAutomatic

End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

 

[buyocan]

Elinize sağlık tam istediğim gibi artık