mdb , txt , csv , xls uzantılı dosyaları excelle çevirme

[halit3]

Bu konu başlığında csv uzantılı dosyaları excelle çevirme ile ilgili kodlar mevcut

kod:

Dim msg1
Dim Klasor2
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

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 ı !")

Liste1 (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 Liste1(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


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 Klasor2 & "\" & 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
Liste1 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[halit3]

Bu konu başlığında txt uzantılı dosyaları excelle çevirme ile ilgili kodlar mevcut

Dim msg1
Dim Klasor2
Sub txt_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

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 ı !")

Liste2 (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 Liste2(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)) = "txt" Then


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)


Workbooks.OpenText Filename:=dosya, DataType:=xlDelimited, Tab:=True
        
Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Klasor2 & "\" & fs.GetBaseName(dosya) & "." & uzanti2, FileFormat:=FileFormatNum '6   '-4158 'xlText
ActiveWindow.Close
'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
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[halit3]

Bu konu başlığında mdb uzantılı dosyaları excelle çevirme ile ilgili kodlar mevcut

Dim msg1
Dim Klasor2
Dim veri(100)

Sub mdb_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

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 ı !")

Liste4 (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 Liste4(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

uzanti3 = fs.GetExtensionName(dosya)

If uzanti = "xls" Then
aranan1 = "mdb"
aranan2 = "mdb"
ElseIf uzanti = "xlsm" Then
aranan1 = "mdb"
aranan2 = "accdb"
End If

If LCase(fs.GetExtensionName(dosya)) = aranan1 Or LCase(fs.GetExtensionName(dosya)) = aranan2 Then

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
'On Error Resume Next

Dim Katalog As Object, Data3 As Object, Tablo As Object

Set Data3 = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")

saydir = 0

If uzanti3 = "mdb" Or uzanti = "accdb" Then
If uzanti3 = "mdb" Then
Data3.Open "Driver={Microsoft Access Driver (*.mdb)};Dbq=" & dosya & ";Uid=Admin;Pwd=" & sifre & ";"
ElseIf uzanti = "accdb" Then
Data3.Open "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=" & dosya & ";Uid=Admin;Pwd=" & sifre & ";"
End If
Katalog.ActiveConnection = Data3
For Each Tablo In Katalog.Tables
If Tablo.Type = "TABLE" Then
saydir = saydir + 1
veri(saydir) = Tablo.Name
End If
Next
Data3.Close
Set Data3 = Nothing
Set Katalog = Nothing
End If


On Error GoTo No_Connection

If saydir = 1 Then veri(1) = ""
For k = 1 To saydir
Workbooks.OpenDatabase Filename:=dosya ', _
 CommandText:="Orders", _
 CommandType:=xlCmdTable, _
 BackgroundQuery:=True, _
 ImportDataAs:=xlPivotTableReport

Dim qt As QueryTable
For Each ws In ActiveWorkbook.Worksheets
For Each qt In ws.QueryTables
qt.Delete
Next qt
Next ws


Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Klasor2 & "\" & fs.GetBaseName(dosya) & veri(k) & "." & uzanti2, FileFormat:=FileFormatNum  '6   '-4158 'xlText
ActiveWindow.Close
Next

If msg1 = vbYes Then
fs.DeleteFile dosya
End If


No_Connection:
End If
End If
Next

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

Set fL = Nothing
End Sub