Çözüldü xls uzantılı arşiv nasıl xlsx ve xlsm yapılır?

[assenucler]

Merhabalar;


Arşivimde binlerce xls uzantılı dosyalar bulunmaktadır. Bu dosyalar makroyla xlsx ve xlsm dosyalarına nasıl dönüştürülebilir?

Yardımınızı bekliyorum.

 

[turist]

Aşağıdaki "Örnek" bir Kod.
"c:\temp\" kısmını kendinize uyarlayın.
Kod yabancı kaynaktandır.(http://codebyjoshua.blogspot.com/2013/03/convert-excel-xls-to-xlsx-and-xlsm.html)

Denenmemiştir, Kod'u kullanmadan önce mutlaka dosyalarınızın yedeklerini alın .


Sub Convert_XLS_to_XLSX(ByVal deleteXLS As Boolean)
' Allow user to choose a folder, where all .xls files in that folder will be converted to
' .xlsx or .xlsm format, depending on whether they have macros or not...
Dim xDirect$, xFname$, InitialFoldr$
Dim wbk As New Workbook
Dim msg As Integer
InitialFoldr$ = "c:\temp\" 'Startup folder to begin searching from
If deleteXLS = True Then 'as user if they really want to delete .xls files
msg = MsgBox("Do you want to delete all .xls files after you have created a copy in .xlsx format? If you are not sure, click NO!", vbYesNo, "Ready to delete .xls files?")
End If
If msg = vbNo Then 'user doesn't want to delete files...
deleteXLS = False
End If
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder containing the .xls files you want to convert..."
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> "" 'loop through all filenames in folder
If Right(xFname$, 4) = ".xls" Then 'only convert .xls files
Application.DisplayAlerts = False 'turn off any unwanted messages
Set wbk = Workbooks.Open(Filename:=xDirect$ & xFname$)
If wbk.HasVBProject Then ' convert Excel files containing Macros
wbk.SaveAs Filename:=xDirect$ & xFname$ & "m", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
Else ' convert standard Excel files
wbk.SaveAs Filename:=xDirect$ & xFname$ & "x", _
FileFormat:=xlOpenXMLWorkbook
End If

wbk.Close SaveChanges:=False

If deleteXLS = True Then 'delete existing xls files if desired

With New FileSystemObject 'include Excel reference to Microsoft Scripting.Runtime library... or this won't work... Go to Tools>References in the VBA editing window
If .FileExists(xDirect$ & xFname$) Then
.DeleteFile xDirect$ & xFname$
End If
End With
End If
Application.DisplayAlerts = True 'turn messages back on
End If
xFname$ = Dir ' get next filename in folder
Loop
End If
End With
xRow = MsgBox("All .xls files have now been converted.", , "Finished!")
End Sub

Sub Copy_XLS_as_XLSX()
Convert_XLS_to_XLSX False
End Sub

Sub Delete_XLS_after_Copy_XLS_as_XLSX()
Convert_XLS_to_XLSX True
End Sub

 

[assenucler]

Sayın turist,

İlginiz için teşekkürler.
Masa üstünde "AKTAR" klasöründe xls uzantılı dosyaları, F: harici diskte "ARSIV" klasörüne aktarmak için kodlara nasıl bir ekleme yapmak gerekiyor?

 

[halit3]

Alternatif kod
kırmızı bölümü siz f harici diske ait klasör yolunu yazmalısınız.
kodların çalışması için makrolar etkin olmalı ayrıca
vba projesi nesne modeli erişimine güven tiki işaretli olmalı

Sub Dosyaları_farklı_kayıt_yap()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
Application.ScreenUpdating = False
Liste (Kaynak)

Application.ScreenUpdating = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(Yol As String)
Dim fs As Object, f As Object, j As Long
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
'On Error Resume Next
For Each dosya In fs.GetFolder(Yol).Files
If ThisWorkbook.Name <> dosya.Name Then
Set wb = Workbooks.Open(dosya)

uzanti = "xlsx"
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
bit = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule.CountOfLines
If bit > 0 Then
For i = 1 To bit
If Len(ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule.Lines(i, 1)) > 0 Then
uzanti = "xlsm"
GoTo atla1
Exit For
End If
Next
End If
Next
atla1:


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

If uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
End If

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\veri1\" & fL.GetFileName(dosya.Name), FileFormat:=FileFormatNum
ActiveWorkbook.Close SaveChanges:=False
'wb.Save
'wb.Close
End If
Next
On Error GoTo sonraki
For Each f In fs.GetFolder(Yol).subfolders
Liste (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub

 

[assenucler]

Üstadım,


Öncelikle emek ve paylaşımınız için teşekkürler.

Kod bilgim sıfır. Yukarıdaki iletinizdeki kırmızı kod satırı ........ F:\harici hard diskteki "ARSIV" klasörü için:

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\F:\ARSIV\" & fL.GetBaseName(dosya), FileFormat:=FileFormatNum

üst satırdaki gibi mi olmalı?

Masaüstündeki klasör AKTAR ilişiktedir ve içinde 3 excel dosyası bulunmaktadır.

 

[halit3]

ActiveWorkbook.SaveAs "F:\ARSIV\" & fL.GetFileName(dosya.Name), FileFormat:=FileFormatNum


böyle yapınca olması lazım

 

[assenucler]

ActiveWorkbook.SaveAs "F:\ARSIV\" & fL.GetFileName(dosya.Name), FileFormat:=FileFormatNum

böyle yapınca olması lazım

4. iletideki 3 ve 4. satırdaki uyarınıza göre gerekenleri yaptım.

Makroyu çalıştırınca aldığım mesajın resmini yolluyorum. Ne yapmam gerekiyor?

 

[halit3]

sarı alanı 6 nolu mesajdaki gibi yapacaksınız.

ActiveWorkbook.SaveAs "F:\ARSIV\" & fL.GetFileName(dosya.Name), FileFormat:=FileFormatNum

 

[halit3]

Koddaki kırmızı yeri kendine göre yaz.

Sub Dosyaları_farklı_kayıt_yap()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Liste (Kaynak)

Application.ScreenUpdating = True
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fs As Object, f As Object, j As Long
Set fs = CreateObject("Scripting.FileSystemObject")
Dim wb As Workbook
'On Error Resume Next
For Each dosya In fs.GetFolder(yol).Files
If ThisWorkbook.Name <> dosya.Name Then
Set wb = Workbooks.Open(dosya)

uzanti = "xlsx"
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
bit = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule.CountOfLines
If bit > 0 Then
For i = 1 To bit
If Len(ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule.Lines(i, 1)) > 0 Then
uzanti = "xlsm"
GoTo atla1
Exit For
End If
Next
End If
Next
atla1:


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")


If uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
End If

Kaynak2 = "F:\ARSIV\"     'ThisWorkbook.Path & "\veri1\"

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Kaynak2 & fL.GetBaseName(dosya.Name) & "." & uzanti, FileFormat:=FileFormatNum
'ActiveWorkbook.Close SaveChanges:=False
'wb.Save
wb.Close
End If
Next
On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next
Set fs = Nothing
End Sub

 

[halit3]

Dosyayı ekliyorum
Dosyada iki adet uygulama var her iki uygulama da da önce dosyaların bulunduğu klasör seçilecek daha sonra hedef klasör seçilecek.

 

[assenucler]

Halit Bey,


Gününüz aydınlık, neşeniz, sağlığınız yerinde ve her şey gönlünüzce olsun.

Dün akşam biraz keyifsizdim, internetten çıktım. Mesajınızı biraz önce gördüm. 2004 yılından bugüne gelen xls dosyalardan dolayı, bazen sıkıntılar yaşıyordum. Beni çok büyük bir sıkıntıdan kurtardınız. Sağ olun, var olun. Çok teşekkür ederim. Allah sizden razı olsun.

Saygılar.

 

[halit3]

Halit Bey,


Gününüz aydınlık, neşeniz, sağlığınız yerinde ve her şey gönlünüzce olsun.

Dün akşam biraz keyifsizdim, internetten çıktım. Mesajınızı biraz önce gördüm. 2004 yılından bugüne gelen xls dosyalardan dolayı, bazen sıkıntılar yaşıyordum. Beni çok büyük bir sıkıntıdan kurtardınız. Sağ olun, var olun. Çok teşekkür ederim. Allah sizden razı olsun.

Saygılar.

Teşekkürler iyi çalışmalar