Merhabalar.
Klasör içinde dosylarımın tamamında "Ahmet" isimli sayfa var.
Aynı kitap içine bu sayfalardan 5 er adet kopya almak istiyorum.
Aşağıdaki kod Halit Hocama ait bu kod ile
her seferinde 1 sayfa kopyalanıyor. Kod düzeltilmeye
müsait ise düzeltme; yoksa şayet yeni kod yazılabilinirse çok
sevinirim.
Saygılarımla.
Klasör içinde dosylarımın tamamında "Ahmet" isimli sayfa var.
Aynı kitap içine bu sayfalardan 5 er adet kopya almak istiyorum.
Aşağıdaki kod Halit Hocama ait bu kod ile
her seferinde 1 sayfa kopyalanıyor. Kod düzeltilmeye
müsait ise düzeltme; yoksa şayet yeni kod yazılabilinirse çok
sevinirim.
Saygılarımla.
Kod:
Dim bulunan As String
Dim aranan As String
Dim deg1 As String
Sub Dosya_Listele7()
aranan = InputBox("değiştireceğiniz veya sileceğiniz veya kopyalıyacağınız sayfa adını yaz.", "aranan değer", "")
If aranan = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
bulunan = InputBox("Eğer değiştirecek veya kopyalıyacaksanız yeni sayfa adını yazın silecekseniz rasgele birşey yazın.", "değiştiren değer", "")
If bulunan = "" Then
MsgBox "İşlemi iptal ettiniz"
Exit Sub
End If
a = MsgBox("Sayfa adı değiştirmek için EVET tıklayınız. " & Chr(10) & Chr(10) & _
"sayfayı silmek için HAYIR tıklayınız. " & Chr(10) & Chr(10) & _
"sayfayı kopyalamak için İPTAL tıklayınız. ?", vbYesNoCancel + vbInformation, " Uyarı")
If a = vbYes Then
deg1 = 1
End If
If a = vbNo Then
deg1 = 2
End If
If a = vbCancel Then
deg1 = 3
End If
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
Liste4 (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 Liste4(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
For Each Dosya In fs
If ThisWorkbook.Name <> Dosya.Name Then
Dim wb As Workbook
Set wb = Workbooks.Open(Dosya)
For Each syf In Workbooks(Dir(Dosya)).Worksheets
Sheets(syf.Name).Select
If syf.Name = aranan Then
If deg1 = 1 Then
'değiştir
Sheets(syf.Name).Name = bulunan
Exit For
ElseIf deg1 = 2 Then
'sil
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Exit For
'kopyala
ElseIf deg1 = 3 Then
Sheets(syf.Name).Copy After:=Sheets(ActiveWorkbook.Sheets.Count)
Sheets(ActiveSheet.Name).Name = bulunan
Exit For
End If
End If
Next syf
ActiveWorkbook.Save
ActiveWorkbook.Close
End If
Next
On Error GoTo sonraki
For Each f In fL
Liste4 (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub
)