Excel Dosyalarını csv formatında kayıt yapmak

[halit3]

Bir üyemizin sorduğu sorusuna cevap yazmak için hazırladım bu kodu ama hangi üyemizdi bilemeyeceğim çünkü konusunu silmiş.
kodun işlevi klasördeki excell dosyalarını csv dosyasına çeviriyor.

Dim msg1
Dim Klasor2

Sub csvye_cevir3()

Sayfa_adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").browseforfolder(0, "Lütfen bir klasör seçiniz", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path

If InStr(1, Kaynak, "{") > 0 Then GoTo atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Klasor2 = ""
Klasor2 = Kaynak & "Excel Dosyaları"

If CreateObject("Scripting.FileSystemObject").FolderExists(Klasor2) = False Then
MkDir Klasor2
End If

msg1 = MsgBox("Csv Dosyalarını" & Chr(10) & Chr(10) & _
 "silmek için  EVET tıklayınız. " & Chr(10) & Chr(10) & _
"silmemek için HAYIR tıklayınız.", vbYesNo + vbInformation, "u y a r ı !")

Liste3 (Klasor.Items.Item.Path)

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Klasor2 = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Klasor = Nothing

End Sub

Private Sub Liste3(yol As String)
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")

uzanti = fs.GetExtensionName(ThisWorkbook.Name)
Dim wb As Workbook

For Each dosya In fs.getfolder(yol).Files
If ThisWorkbook.Name <> dosya.Name Then

If uzanti = "xls" Then
aranan1 = "xls"
aranan2 = "xls"
aranan3 = "xls"
aranan4 = "xls"

ElseIf uzanti = "xlsm" Then
aranan1 = "xls"
aranan2 = "xlsx"
aranan3 = "xlsm"
aranan4 = "xlsb"
End If

If LCase(fs.GetExtensionName(dosya)) = aranan1 Or LCase(fs.GetExtensionName(dosya)) = aranan2 Or LCase(fs.GetExtensionName(dosya)) = aranan3 Or LCase(fs.GetExtensionName(dosya)) = aranan4 Then
Set wb = Workbooks.Open(dosya)
Application.DisplayAlerts = False
wb.SaveAs Filename:=Klasor2 & "\" & fs.GetBaseName(dosya) & ".csv", FileFormat:=xlCSVMSDOS, Local:=True
wb.Close False

If msg1 = vbYes Then
fs.DeleteFile dosya
End If

End If
End If
Next

On Error GoTo sonraki
For Each f In fs.getfolder(yol).subfolders
Liste3 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[Haluk]

Halit Bey, üyeler açtıkları konularda ilk mesajlarını ve dolayısıyle konuyu silemiyorlar artık ....

Forumun "Test" alanında ben deneme yaptım.

.

 

[halit3]

Merhaba Haluk Bey
Herhalde salı günüydü bir üyemiz açmıştı konuyu belkide yöneticilerden silmesini talep etmiş olabilir.