2 çalışma sayfasını aynı dosyaya farklı kaydetme

[muhalko]

ELİMDEKİ BİR ÇALIŞMA KİTABININ 3. SAYFASINDA BULUNAN BUTONA TIKLADIĞIMA;

1 - 1 VE 2. SAYFALARI FARKLI KAYDEDİP, C:\Users\mkose\Desktop\İnsan Kaynakları Paylaşım\İnsan Kaynakları Yönetmenliği\2013 KLASÖRÜ İÇİNE KAYDETMESİ

2 - BU KAYDI YAPARKEN 3. SAYFA B 1 DEKİ DEĞERE GÖRE KLASÖR AÇMASI, EĞER KLASÖR VARSA VAR OLAN KLASÖRÜN İÇİNE KOPYALAMASI

3 - YİNE SAYFA 3 B2 DE BULUNAN ADA GÖRE DOSYAYI İSİMLENDİRME YAPACAK
BİR KOD LAZIM.

YARDIMCI OLURSANIZÇOK SEVİNİRİM.

 

[halit3]

ELİMDEKİ BİR ÇALIŞMA KİTABININ 3. SAYFASINDA BULUNAN BUTONA TIKLADIĞIMA;

1 - 1 VE 2. SAYFALARI FARKLI KAYDEDİP, C:\Users\mkose\Desktop\İnsan Kaynakları Paylaşım\İnsan Kaynakları Yönetmenliği\2013 KLASÖRÜ İÇİNE KAYDETMESİ

2 - BU KAYDI YAPARKEN 3. SAYFA B 1 DEKİ DEĞERE GÖRE KLASÖR AÇMASI, EĞER KLASÖR VARSA VAR OLAN KLASÖRÜN İÇİNE KOPYALAMASI

3 - YİNE SAYFA 3 B2 DE BULUNAN ADA GÖRE DOSYAYI İSİMLENDİRME YAPACAK
BİR KOD LAZIM.

YARDIMCI OLURSANIZÇOK SEVİNİRİM.

Kod:

Sub farklı_kayıtet()


Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya = ThisWorkbook.FullName
Uzanti = fL.GetExtensionName(Dosya)

If Uzanti = "xls" Then
FileFormatNum = -4143
ElseIf Uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf Uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf Uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If

ReDim kaynak(3)
ReDim Sayfaadi(3)
ReDim dosya_adi(3)

yer = [COLOR="Red"]ThisWorkbook.Path[/COLOR]

kaynak(1) = yer
kaynak(2) = yer
kaynak(3) = yer & "\" & Cells(2, "b").Value

If CreateObject("Scripting.FileSystemObject").FolderExists(kaynak(3)) = False Then
MkDir kaynak(3)
End If

Sayfaadi(1) = "Sayfa1"
Sayfaadi(2) = "Sayfa2"
Sayfaadi(3) = "Sayfa3"

dosya_adi(1) = Sayfaadi(1)
dosya_adi(2) = Sayfaadi(2)
dosya_adi(3) = Cells(3, "b").Value

For i = 1 To 3
Sheets(Sayfaadi(i)).Copy
ActiveWorkbook.SaveAs kaynak(i) & "\" & dosya_adi(i) & "." & Uzanti, FileFormat:=FileFormatNum
ActiveWorkbook.Close False
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam.?", vbInformation, "uyarı!"


End Sub

Kırmızı yeri kendiniz belirleyin orası dosyanın kayıt yapılacağı yerdir. Kod bu haliyle dosyanın hemen yanına kayıt yapmaktadır.

 

[muhalko]

SAYIN HALİT3;

ÖNCELİKLE İLGİNİZ İÇİN ÇOK TEŞEKKÜR EDERİM. FARKLI KAYDET MAKROSU GAYET GÜZEL ÇALIŞIYOR. ANCAK KAYDET DEDİĞİM ZAMAN, ÖRNEK ÇALIŞMA KİTABININ 1 VE 2. SAYFALARINDAN OLUŞAN YENİ BİR KİTAP OLUŞTURMASINI VE 3. SAYFADAKİ KLASÖR ADI İLE DOSYA ADINI KULLANMASINI İSTİYORUM.

AYRICA

yer = ThisWorkbook.Path KISMINA AŞAĞIDAKİ YERİ YAZDIĞIMDA HATA VERİYOR.

yer = C:\Users\mkose\Desktop\İnsan Kaynakları Paylaşım\İnsan Kaynakları Yönetmenliği\2013

SAYIN UZMANIM,

BU KONUDA YARDIMINIZI ESİRGEMEZSENİZ MEMNUN OLURUM.

KOLAY GELSİN....

 

[halit3]

SAYIN HALİT3;

ÖNCELİKLE İLGİNİZ İÇİN ÇOK TEŞEKKÜR EDERİM. FARKLI KAYDET MAKROSU GAYET GÜZEL ÇALIŞIYOR. ANCAK KAYDET DEDİĞİM ZAMAN, ÖRNEK ÇALIŞMA KİTABININ 1 VE 2. SAYFALARINDAN OLUŞAN YENİ BİR KİTAP OLUŞTURMASINI VE 3. SAYFADAKİ KLASÖR ADI İLE DOSYA ADINI KULLANMASINI İSTİYORUM.

AYRICA

yer = ThisWorkbook.Path KISMINA AŞAĞIDAKİ YERİ YAZDIĞIMDA HATA VERİYOR.

yer = C:\Users\mkose\Desktop\İnsan Kaynakları Paylaşım\İnsan Kaynakları Yönetmenliği\2013

SAYIN UZMANIM,

BU KONUDA YARDIMINIZI ESİRGEMEZSENİZ MEMNUN OLURUM.

KOLAY GELSİN....

Sorunuz aynen şöyleydi
(1 - 1 VE 2. SAYFALARI FARKLI KAYDEDİP, C:\Users\mkose\Desktop\İnsan Kaynakları Paylaşım\İnsan Kaynakları Yönetmenliği\2013 KLASÖRÜ İÇİNE KAYDETMESİ)

Burada 1 ve 2. sayfaları farklı kaydetmek geçiyor.

Diğer sorunuz değişkeni tırnak içine almanız gerekir.

yer = "C:\Users\mkose\Desktop\İnsan Kaynakları Paylaşım\İnsan Kaynakları Yönetmenliği\2013"

 

[halit3]

kod:

Sub farklı_kayıtet()


Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya = ThisWorkbook.FullName
Uzanti = fL.GetExtensionName(Dosya)

If Uzanti = "xls" Then
FileFormatNum = -4143
ElseIf Uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf Uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf Uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If

'yer = ThisWorkbook.Path
yer = "C:\Users\mkose\Desktop\İnsan Kaynakları Paylaşım\İnsan Kaynakları Yönetmenliği\2013"
kaynak = yer & "\" & Sheets("Sayfa3").Cells(2, "b").Value
If CreateObject("Scripting.FileSystemObject").FolderExists(kaynak) = False Then
MkDir kaynak
End If
dosya_adi = Sheets("Sayfa3").Cells(3, "b").Value


Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 0
If Sheets(i).Name = "Sayfa1" Then
r = 1
ElseIf Sheets(i).Name = "Sayfa2" Then
r = 1
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i
Sheets(myArray).Select
Sheets(myArray).Copy

ActiveWorkbook.SaveAs kaynak & "\" & dosya_adi & "." & Uzanti, FileFormat:=FileFormatNum
ActiveWindow.Close

Sheets("Sayfa3").Select

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "işlem tamam.?", vbInformation, "uyarı!"


End Sub

 

[muhalko]

Sayın uzmanım;

ellerinize sağlık çok teşekkür ederim. Tam istediğim gibi olmuş.

Boşuna işi ehline bırakın demiyorlarmış.

Tekraren teşekkür ediyorum ellerinize sağlık.