• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

2007 den .xls olarak farklı kaydet makrosu

P

peleryn

Katılım
10 Mayıs 2009
Mesajlar
1,080
Excel Vers. ve Dili
2003 türkçe
Herkese merhabalar;

Excel 2003 te kullandığım makrolu bir dosyayı xlsm olarak excel 2007 ye adapte ettim.Bu dosyadaki farklı kaydet makrosu hücreden bir ad alarak bu ada .xls uzantısı ekleyip yeni bir 2003 dosyası oluşturuyordu.Şimdi 2007 ye adapte edilmiş haliyle makroyu çalıştırıp .xls uzantılı dosyayı oluşturduğumda 2003 te dosyayı açarken hata veriyor ve dosya biçimini tanımadığını belirtiyor.Uzantıyı .xlsx olarak değiştirdiğimde de aynı sorun söz konusu.Heralde basit bir çözümü vardır ama malesef bulamadım.Yardımcı olan olursa sevinirim.İlgilenecek olanlara şimdiden teşekkürler.

.....
yer = kaynak & "\" & Sheets("PERFORMANS KAYIT").adsayfa.Value & " " & _
Format([az3], "mmmm.yy") & " " & Sheets("PERFORMANS KAYIT").ComboBox1.Value & ".xls"
.....
Genişletmek için tıkla ...
 
Selamlar,

Verdiğiniz kod bloğunda bir sorun görünmüyor. Sanırım kaydetme işlemini yapan satırda problem yaşıyorsunuz. Bu satırı foruma eklermisiniz.
 
peleryn' Alıntı:
Herkese merhabalar;

Excel 2003 te kullandığım makrolu bir dosyayı xlsm olarak excel 2007 ye adapte ettim.Bu dosyadaki farklı kaydet makrosu hücreden bir ad alarak bu ada .xls uzantısı ekleyip yeni bir 2003 dosyası oluşturuyordu.Şimdi 2007 ye adapte edilmiş haliyle makroyu çalıştırıp .xls uzantılı dosyayı oluşturduğumda 2003 te dosyayı açarken hata veriyor ve dosya biçimini tanımadığını belirtiyor.Uzantıyı .xlsx olarak değiştirdiğimde de aynı sorun söz konusu.Heralde basit bir çözümü vardır ama malesef bulamadım.Yardımcı olan olursa sevinirim.İlgilenecek olanlara şimdiden teşekkürler.
Genişletmek için tıkla ...

Kod: 
& [COLOR=red]" "[/COLOR] &

Yukarıdaki kırmızı renkli iki tırnak arası boşlukları al birde öyle dene

Kod: 
yer = kaynak & "\" & Sheets("PERFORMANS KAYIT").adsayfa.Value & _
Format([az3], "mmmm.yy") & Sheets("PERFORMANS KAYIT").ComboBox1.Value & ".xls"
 
Korhan Ayhan' Alıntı:
Selamlar,

Verdiğiniz kod bloğunda bir sorun görünmüyor. Sanırım kaydetme işlemini yapan satırda problem yaşıyorsunuz. Bu satırı foruma eklermisiniz.
Genişletmek için tıkla ...


Korhan hocam kodlar kitaptaki vba içeriğini silip yeni adıyla belirtilen klasöre farklı kaydediyor.

Sub kaydet()
Call nesnesil
On Error Resume Next
Dim Baslik As String
Baslik = "Kayıt yapacağınız klasörü seçiniz."
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
kaynak = Klasor.items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, kaynak, "{") > 0 Then GoTo Atla
If Len(kaynak) = 3 Then
kaynak = Mid(kaynak, 1, 2)
End If
On Error Resume Next
With ActiveWorkbook.VBProject
For x = .VBComponents.Count To 1 Step -1
.VBComponents.Remove .VBComponents(x)
Next x
For x = .VBComponents.Count To 1 Step -1
.VBComponents(x).CodeModule.DeleteLines _
1, .VBComponents(x).CodeModule.CountOfLines
Next x
End With
On Error GoTo 0
yer = kaynak & "\" & Sheets("PERFORMANS KAYIT").adsayfa.Value & " " & _
Format([az3], "mmmm.yy") & Sheets("PERFORMANS KAYIT").ComboBox1.Value & ".xls"
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(deg)
If a = True Then
MsgBox "Bu isimde bir dosya var"
Else
ActiveWorkbook.SaveAs Filename:=yer
End If

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
End Sub
Genişletmek için tıkla ...
 
halit3' Alıntı:
Kod: 
& [COLOR=red]" "[/COLOR] &

Yukarıdaki kırmızı renkli iki tırnak arası boşlukları al birde öyle dene

Kod: 
yer = kaynak & "\" & Sheets("PERFORMANS KAYIT").adsayfa.Value & _
Format([az3], "mmmm.yy") & Sheets("PERFORMANS KAYIT").ComboBox1.Value & ".xls"
Genişletmek için tıkla ...

Halit hocam denedim malesef birşey değişmiyor.Sorun aynı şekilde devam ediyor.
 
Merhaba,
Kod: 
ActiveWorkbook.SaveAs Filename:=yer
satırını,

Kod: 
ActiveWorkbook.SaveAs yer, FileFormat:=56

ile değiştirerek denermisiniz. Kolay gelsin.
 
Sn dentex çok teşekkür ederim halloldu.

İlk olarak böyle yaparak ne yapmış olduk.?İkinci bir sorum da uzantıyı xlsx yapmam için ne yapmam gerekir bilginiz var mıdır?
 
Merhaba,
"FileFormat:=56" 2003 excel için dosya formatıdır. "xlsx" için "FileFormat:=51" kullanmalısınız. Tabii ki "yer" değişkenindeki uzantı da "xlsx" olarak değiştirilmelidir. İyi çalışmalar.
 
dentex' Alıntı:
Merhaba,
"FileFormat:=56" 2003 excel için dosya formatıdır. "xlsx" için "FileFormat:=51" kullanmalısınız. Tabii ki "yer" değişkenindeki uzantı da "xlsx" olarak değiştirilmelidir. İyi çalışmalar.
Genişletmek için tıkla ...

Sn dentex değerli yardımınız ve açıklamanız için teşekkür ederim.Ürettiğim 2 sürüm de kendi sürümlerinde açılıyor sağolun.
 
peleryn' Alıntı:
Halit hocam denedim malesef birşey değişmiyor.Sorun aynı şekilde devam ediyor.
Genişletmek için tıkla ...

Alternatif olarak birde bu kodu denermisiniz.


Kod: 
Sub kaydet()
Sayfa_Adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
Kaynak = Klasor.SELF.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
 
If Right(Kaynak, 1) = "\" Then
Kaynak = Kaynak
Else
Kaynak = Kaynak & "\"
End If
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
yer = Mid(ThisWorkbook.Name, 1, i - 1)
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
 
'yer = Kaynak & Sheets("PERFORMANS KAYIT").adsayfa.Value & "_" & _
Format([az3], "mmmm.yy") & Sheets("PERFORMANS KAYIT").ComboBox1.Value
yer = Kaynak & Format(Now, "yyyy-mm-dd hh-mm-ss")
 
 
ThisWorkbook.Worksheets.Select
ThisWorkbook.Worksheets.Copy
Application.DisplayAlerts = False
If Uzanti = ".xlsx" Then
ActiveWorkbook.SaveAs yer & ".xlsm", FileFormat:=52
ElseIf Uzanti = ".xlsm" Then
ActiveWorkbook.SaveAs yer & ".xlsm", FileFormat:=52
ElseIf Uzanti = ".xls" Then
ActiveWorkbook.SaveAs yer & ".xls", FileFormat:=-4143
End If
For i = ActiveWorkbook.Sheets.Count To 1 Step -1
Sheets(i).Select
ActiveSheet.DrawingObjects.Delete
Next i
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next
ActiveWorkbook.Save
ActiveWindow.Close
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 
11 nolu mesajdaki kodu yeniden düzenledim.
 
Halit hocam kodu denedim ancak malesef sonuç alamadım.Dosyayı yüklüyorum.Sağdaki Fazla satırları sil dosyayı kaydet butonuna yazılacak kodlar hocam.
 

Ekli dosyalar

peleryn' Alıntı:
Halit hocam kodu denedim ancak malesef sonuç alamadım.Dosyayı yüklüyorum.Sağdaki Fazla satırları sil dosyayı kaydet butonuna yazılacak kodlar hocam.
Genişletmek için tıkla ...

Sayfanın içindeki kodlar engelliyormuş. Birde bunu dene.?

Kod: 
Sub kaydet()
Sayfa_Adı = ActiveSheet.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
Kaynak = Klasor.SELF.Path
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) = "\" Then
Kaynak = Kaynak
Else
Kaynak = Kaynak & "\"
End If
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
Exit For
End If
Next
i = 0
ad = "PERFORMANS KAYIT"
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(Worksheets(ad).CodeName).CodeModule
deg2 = ""
Do While VBCodeMod.CountOfLines > 0
DoEvents
i = i + 1
deg1 = ThisWorkbook.VBProject.VBComponents(Worksheets(ad).CodeName).CodeModule.Lines(i, 1)
If deg1 <> "" Then
deg2 = deg2 & deg1 & Chr(13)
End If
If i = VBCodeMod.CountOfLines Then
deg = deg2
Exit Do
End If
Loop
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(Worksheets(ad).CodeName).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next
'yer = Kaynak & Sheets("PERFORMANS KAYIT").adsayfa.Value & "_" & _
Format([az3], "mmmm.yy") & Sheets("PERFORMANS KAYIT").ComboBox1.Value
yer = Kaynak & Format(Now, "yyyy-mm-dd hh-mm-ss")
ActiveSheet.Copy
If Uzanti = ".xlsx" Then
ActiveWorkbook.SaveAs yer & ".xlsx", FileFormat:=51
ElseIf Uzanti = ".xlsm" Then
ActiveWorkbook.SaveAs yer & ".xlsx", FileFormat:=51
Else
ActiveWorkbook.SaveAs Filename:=yer & Uzanti
End If
ActiveSheet.DrawingObjects.Delete
ActiveWorkbook.Save
ActiveWindow.Close
ThisWorkbook.VBProject.VBComponents(Worksheets(ad).CodeName).CodeModule.InsertLines 1, deg
Sheets(Sayfa_Adı).Select
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 
Halit hocam haklısınız engel olan diğer kodlarmış.İlginize teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst