- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,852
- Excel Vers. ve Dili
-
2003 excell türkçe
ve
2007 excell türkçe
CSV Uzantılı dosyaları Excelle çevirme ile ilgili çalışma
kod:
kod:
Kod:
Dim msg1
Sub csvye_cevir()
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
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
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 LCase(fs.GetExtensionName(dosya)) = "csv" Then
ad = yol & "\" & "Excel Dosyaları"
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If
If uzanti = "xls" Then
FileFormatNum = -4143
uzanti2 = "xls"
ElseIf uzanti = "xlsm" Then
FileFormatNum = 51
uzanti2 = "xlsx"
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
uzanti2 = "xlsx"
End If
Set wb = Workbooks.OpenXML(dosya)
Application.DisplayAlerts = False
wb.SaveAs ad & "\" & fs.GetBaseName(dosya) & "." & uzanti2, FileFormat:=FileFormatNum '6 '-4158 'xlText
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