dosya seç ve farklı kaydet kodumdaki problem.

[rastbin]

Private Sub CommandButton1_Click()
Dim sFileName As String
    sFileName = Application.GetOpenFilename
    Label1 = sFileName
        Workbooks.Open Filename:=sFileName
    If Range("a3") = "Unvan:" Then
        ActiveWorkbook.SaveAs 
   Filename:="C:\Users\...\Desktop\FinansBank.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
    ElseIf Range("b8") = "xxxx" Then
        ActiveWorkbook.SaveAs Filename:="C:\Users\...\Desktop\fiba.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
    ElseIf Range("a1") = "Şube*" Then
        ActiveWorkbook.SaveAs Filename:="C:\Users\...\Desktop\SekerBank.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
    ElseIf Range("a2") = "Şube;PLAZA KURUMSAL;;;;" Then
        ActiveWorkbook.SaveAs Filename:="C:\Users\...\Desktop\Akbank.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
        
    Else: MsgBox "bulunamadı"
End If
End Sub

merhaba,elimde 4 adet farklı uzantıda dosyalar var.bunların hepsini cvs formatına çevirmek istiyorum.çevirmek istediğim dosya uzantıları şu şekilde;

.xlsb
.xls

yazdığım bu kod şu an dosya seçiyor,dosyayı alıp adını ve uzantısını değiştirip istediğim yere kaydediyor.ama ben csv dosyasını açtığımda herşeyi a sütununa yazıyor.halbuki ben aynı formatta kalsın sadece uzantısını değiştirmesini istiyorum.nerede yanlış yapıyorum yardımcı olurmusunuz.

 

[turist]

Aşağıdaki gibi deneyin.

Private Sub CommandButton1_Click()
Dim sFileName As String
    sFileName = Application.GetOpenFilename
    Label1 = sFileName
[B][COLOR="Blue"]Application.ScreenUpdating = False
Application.DisplayAlerts = False
[/COLOR][/B]
        Workbooks.Open Filename:=sFileName
    If Range("a3") = "Unvan:" Then
        ActiveWorkbook.SaveAs 
   Filename:="C:\Users\...\Desktop\FinansBank.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
    ElseIf Range("b8") = "xxxx" Then
        ActiveWorkbook.SaveAs Filename:="C:\Users\...\Desktop\fiba.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
    ElseIf Range("a1") = "Şube*" Then
        ActiveWorkbook.SaveAs Filename:="C:\Users\...\Desktop\SekerBank.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
    ElseIf Range("a2") = "Şube;PLAZA KURUMSAL;;;;" Then
        ActiveWorkbook.SaveAs Filename:="C:\Users\...\Desktop\Akbank.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
        
    Else: MsgBox "bulunamadı"
End If
[B][COLOR="blue"]Application.DisplayAlerts = True
Application.ScreenUpdating = True
[/COLOR][/B]
End Sub