xls dosyasını xlsx çevirme

[erdalkoccc]

Merhaba;

Benim elimde 1000'e yakın .xls (Microsoft Excel 97-2003 Çalışma Sayfası ) formatın'da dosya var. Ben bunları tek tek açıp .xlsx formatı'na dönüştürmem çok zaman alacak.
Bunu makro ile nasıl yapabiliriz?
Ben böyle bir kod buldum ama Açık yeşile boyadığım satırda (10.Satır) hata veriyor.

DefObj E
Sub XLS_Dosyalari_XLSM_Donustur()
Dim dosyaad As String
Set evn = CreateObject("scripting.filesystemobject")
Set evnklasor = evn.getfolder("C:\Users\erdal.koc\Desktop\28.01.2020 - Kopya")
For Each evndosya In evnklasor.Files
If VBA.UCase(VBA.Right(evndosya.Name, 3)) = "XLS" Then
dosyaad = Mid(evndosya.Path, 1, Len(evndosya.Path) - 0)
Workbooks.Open evndosya.Path
ActiveWorkbook.SaveAs Filename:=evnad & ".xlsx", FileFormat:=51
ActiveWorkbook.Close
End If
Next
Set evn = Nothing: Set evnklasor = Nothing
Set evndosya = Nothing: dosyaad = vbNullString
End Sub


Yardımlarınız için şimdiden teşekkürler.

Örnek dosya linki altaki gibidir;

Data.xls

drive.google.com

 

[erdalkoccc]

Arkadaşlar Tekrardan Merhaba,
Gerek kalmadı çok teşekkür ederim makroyu buldum.
Belki sizinde işinize yarar diye altta kodu paylaştım işime yaradı çalışıyor.


Sub ChangeFileFormat()

Dim strCurrentFileExt As String
Dim strNewFileExt As String
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim xlFile As Workbook
Dim strNewName As String
Dim strFolderPath As String

strCurrentFileExt = ".xls"
strNewFileExt = ".xlsx"

strFolderPath = "C:\Users\erdal.koc\Desktop\28.01.2020 - Kopya"
If Right(strFolderPath, 1) <> "\" Then
strFolderPath = strFolderPath & "\"
End If

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.getfolder(strFolderPath)
For Each objFile In objFolder.Files
strNewName = objFile.Name
If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then
Set xlFile = Workbooks.Open(objFile.Path, , True)
strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt)
Application.DisplayAlerts = False
Select Case strNewFileExt
Case ".xlsx"
xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbook
Case ".xlsm"
xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled
End Select
xlFile.Close
Application.DisplayAlerts = True
End If
Next objFile

ClearMemory:
strCurrentFileExt = vbNullString
strNewFileExt = vbNullString
Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
Set xlFile = Nothing
strNewName = vbNullString
strFolderPath = vbNullString
End Sub

 

[TURKOLOG]

Sayın @erdalkoccc Bey kodlar için teşekkür ederim . Yapmış olduğunuz dosyayı bizimle paylaşmanız mümkün mü acaba

 

[TURKOLOG]

Size küçük bir hediyem Dosya yolunu Veri sayfasının A5 hücresinden alıyor aha pratik olur diye düşündüm.

 

[erdalkoccc]

Size küçük bir hediyem Dosya yolunu Veri sayfasının A5 hücresinden alıyor aha pratik olur diye düşündüm.

Teşekkürler dediğiniz gibi daha pratik oluyor. Fakat testlerim sonucundan paylaşmış olduğum kodlar her excel sürümünde farklılık gösterebiliyor.
Alta paylaştığım alternatif kod tüm excel sürümlerinde başarılı bir şekilde çalışmaktadır. Kesin sağlıklı çözüm alttaki kod;


Sub ConvertMultipleXlsToXlsx()
Z = TimeValue(Now)


Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim OpenSourceFolder As Object
Dim OpenTargetFolder As Object

Dim SelectedExcelFilesFolder As String
Dim SelectedXlsxFilesFolder As String

Dim InputXlsFile As String
Dim MyOpenedXlsFile As Workbook
Dim ConvertedXlsxlFile As String


Set OpenSourceFolder = Application.FileDialog(msoFileDialogFolderPicker)
Set OpenTargetFolder = Application.FileDialog(msoFileDialogFolderPicker)

'Excel dosyalarının bulunduğu klasörü seçme kodu
MsgBox ("Excel dosyalarının bulunduğu klasörü seçin")
Set OpenSourceFolder = Application.FileDialog(msoFileDialogFolderPicker)

If OpenSourceFolder.Show = -1 Then
SelectedExcelFilesFolder = OpenSourceFolder.SelectedItems(1)
End If

'Hiçbir klasörü seçilmediğinde alttaki kod aktif hale gelir
If SelectedExcelFilesFolder = "" Then
MsgBox "Hiçbir excel klasörü seçilmedi, kod iptal ediliyor...!"
Exit Sub
End If

AppActivate Application.Caption

'Excel XLSX dosyalarının export edileceği klasör seçme kodu
MsgBox ("Excel XLSX dosyalarının export edileceği bir klasör seçin")
If OpenTargetFolder.Show = -1 Then
SelectedXlsxFilesFolder = OpenTargetFolder.SelectedItems(1)
End If

'Hiçbir klasörü seçilmediğinde alttaki kod aktif hale gelir
If SelectedXlsxFilesFolder = "" Then
MsgBox "Dosyaların export edileceği klasör seçilmedi, kod iptal ediliyor...!"
Exit Sub
End If

'Excel dosyalarının yalnızca xls dosyaları arasında geçiş yapma kodu
InputXlsFile = Dir(SelectedExcelFilesFolder & "\*.xls")
While InputXlsFile <> ""

Set MyOpenedXlsFile = Workbooks.Open(SelectedExcelFilesFolder & "\" & InputXlsFile)
ConvertedXlsxlFile = SelectedXlsxFilesFolder & "\" & Replace(ActiveWorkbook.Name, "xls", "xlsx")

'Her excel dosyasını otomatik kaydeder.
ActiveWorkbook.SaveAs Filename:=ConvertedXlsxlFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

MyOpenedXlsFile.Close
InputXlsFile = Dir
Wend

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
"İşlem süresi ; " & CDate(TimeValue(Now) - Z), vbInformation

End Sub

 

[TURKOLOG]

Sayın @erdalkoccc dosyanızı son hali ile eklemeniz mümkün mü. Su an yoldayım dosyanızı eklerseniz incelemek isterim.

 

[erdalkoccc]

Sayın @erdalkoccc dosyanızı son hali ile eklemeniz mümkün mü. Su an yoldayım dosyanızı eklerseniz incelemek isterim.

Dosyamın son hali ilk mesajımda yer almaktadır.

 

[TURKOLOG]

Teşekkür ederim . Data isimli dosyanızı ilk fırsatta inceleyeceğim.

 

[erdalkoccc]

Pardon açılmaya bilir yeni link alttaki gibidir.

Data.xls

drive.google.com

 

[erdalkoccc]

Teşekkür ederim . Data isimli dosyanızı ilk fırsatta inceleyeceğim.

Ben teşekkür ederim. Yeni link attım oradan inceleyebilirsiniz.

 

[TURKOLOG]

9. Mesajdaki dosyanızı indirdim. TEŞEKKÜR EDERİM.