• DİKKAT

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

Sayfaları kendi adı ile çalışma kitabı yap.

B

Bora K

Katılım
21 Ocak 2013
Mesajlar
331
Excel Vers. ve Dili
2003 Türkçe
Merhabalar

Aşağıdaki kod değerli uzmanımız
Halit3 hocamıza ait.

Kod kitaptaki sayfaları (sayfa adı ile) belirtilen bir klasörün içine kitap oluşturuyor.
Lakin makrolar ve modüller yeni oluşturulan kitaplara aktarılmıyor.

Benim istirhamım;
** Kitapta ne kadar modül makro vs var ise
hepsi yeni oluşturulacak kitaplar aktarılsın.

Değerli hocamızdan ve siz değerli uzmanlarımızdan yardım
bekliyorum. Saygılarımla.




Kod: 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Dim baslangıc As Variant
Sub sayfalarıcalismakitabiyap1()
'Working in Excel 97-2010

Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String

'-------------------------------


On Error Resume Next

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya = ThisWorkbook.FullName
dosya_adi = fL.GetBaseName(Dosya)
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


Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, X As Long, pos As Integer
msg = "Lütfen bir klasör seçiniz."
bInfo.pidlRoot = 0&
If IsMissing(msg) Then
bInfo.lpszTitle = "Lütfen bir klasör seçiniz."
Else
bInfo.lpszTitle = msg
End If
'Pencerede sadece klasorleri goruntulemek icin
bInfo.ulFlags = &H1
'Klasör ve dosyaları da beraber görmek istersek
'bInfo.ulFlags = &H4000
X = SHBrowseForFolder(bInfo)
Path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
TempFilePath = Left(Path, pos - 1)
Else
MsgBox "işlemi iptal ettiniz."
Exit Sub
End If


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set Sourcewb = ActiveWorkbook
Dim sayfa As Worksheet
For Each sayfa In Worksheets


If CreateObject("Scripting.FileSystemObject").FileExists(TempFilePath & "\" & sayfa.Name & "." & Uzanti) = True Then
MsgBox sayfa.Name & " Bu isimde bir dosya var"
Else

sayfa.Copy

'TempFilePath = ThisWorkbook.Path & "\" ' Application.DefaultFilePath & "\"
'TempFileName = "Yeni dosya " & Format(Now, "yyyy-mm-dd hh-nn-ss")

Set Destwb = ActiveWorkbook
With Destwb

For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next

.SaveAs TempFilePath & "\" & sayfa.Name & "." & Uzanti, FileFormat:=FileFormatNum
.Close SaveChanges:=False
End With
MsgBox "Kayıt yeri " & TempFilePath & "\" & sayfa.Name & "." & Uzanti
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next

End Sub
 
Son düzenleme:
MsgBox "Kayıt yeri " & TempFilePath & "\" & sayfa.Name & "." & Uzanti
Yazan satırı silin, eğer bir şekilde excel kendi uyarı veriyorsa;
Aşağıdaki kodu eklerseniz, uyarı vermez
Application.DisplayAlerts =False
 
Son düzenleme:
Merhaba Ömer Bey.
Alakanız için teşekkür ederim.

MsgBox "Kayıt yeri " & TempFilePath & "\" & sayfa.Name & "." & Uzanti
yukarıdaki satırı etkisiz hale getirdim ve uyarı almıyorum artık.

Aşağıdaki durum için de öneri/çözümünüz olabilirmi acaba?
** Birde Mevzu kitapta ne kadar modül makro vs var ise
hepsi yeni oluşturulacak kitaplara da aktarılsın.
 
Kod:

Kod: 
Sub deneme()

Application.ScreenUpdating = False

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
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Dosya = ActiveWorkbook.Name

Set fLk = CreateObject("Scripting.FileSystemObject")
Uzanti = fLk.GetExtensionName(Dosya) ' uzantı buluyor
'dosya2 = fLk.GetBaseName(Dosya) ' klasörün kendisi

Dim sayfa As Worksheet
For Each sayfa In Worksheets

Kayıt_Yeri = Kaynak & "\" & sayfa.Name & "." & Uzanti

If CreateObject("Scripting.FileSystemObject").FileExists(Kayıt_Yeri) = True Then
MsgBox sayfa.Name & "." & Uzanti & Chr(10) & "Bu isimde bir dosya var"
Else

fLk.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
Dim wb As Workbook
If ThisWorkbook.Name <> Kayıt_Yeri Then
Set wb = Workbooks.Open(Kayıt_Yeri)
For i = ActiveWorkbook.Sheets.Count To 1 Step -1

If Sheets(i).Name <> sayfa.Name Then
Sheets(Sheets(i).Name).Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End If
Next

wb.Save
wb.Close False
End If
End If

Next

Application.ScreenUpdating = True
MsgBox "İşlem tamam !", vbInformation, "DİKKAT"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub
 
Merhabalar

Halit Hocam ellerinize sağlık.
Çok çok teşekkür ediyorum.

Edit: Saygıdeğer hocam. Kodu bizzat uyguluyorumda şuan.
Kodun işleyiş tarzı şu şekilde olabilirmi acaba?

Örneğin "xxx" adlı kitaptayız ve kodu çalıştırıyoruz.
kod bize açılır pencere vs getirmeyecek.
Kendisi "xxx" in bulunduğu dizine "xxx" adıyla
bir klasör oluşturacak ve farklı kaydedilecek
sayfaları bu klasörün içine atacak.
 
Son düzenleme:
kod:

Kod: 
Sub deneme()

Application.ScreenUpdating = False


Klasor = "D:\DENEME\ankara" 'dosya yolu


Set fLk = CreateObject("Scripting.FileSystemObject")
Uzanti = fLk.GetExtensionName(ActiveWorkbook.Name) ' uzantı buluyor
'dosya2 = fLk.GetBaseName(ActiveWorkbook.Name) ' klasörün kendisi

If fLk.FolderExists(Klasor) = False Then
MkDir Klasor 'burada anakara klasör adı altında bir klasör oluşturuyor.
End If



Dim sayfa As Worksheet
For Each sayfa In Worksheets

Kayıt_Yeri = Klasor & "\" & sayfa.Name & "." & Uzanti

If CreateObject("Scripting.FileSystemObject").FileExists(Kayıt_Yeri) = True Then
MsgBox sayfa.Name & "." & Uzanti & Chr(10) & "Bu isimde bir dosya var"
Else

fLk.CopyFile ThisWorkbook.FullName, Kayıt_Yeri
Dim wb As Workbook
If ThisWorkbook.Name <> Kayıt_Yeri Then
Set wb = Workbooks.Open(Kayıt_Yeri)
For i = ActiveWorkbook.Sheets.Count To 1 Step -1

If Sheets(i).Name <> sayfa.Name Then
Sheets(Sheets(i).Name).Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End If
Next

wb.Save
wb.Close False
End If
End If

Next

Application.ScreenUpdating = True
MsgBox "İşlem tamam !", vbInformation, "DİKKAT"


End Sub
 
Saygılar
Halit Hocam.

Herşey gönlünüzce olsun inşallah.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst