Kod: Tümünü seç
Sub KitabıKopyala(KitapPath As String)
Application.ScreenUpdating = False
Dim currentUser As String
currentUser = Environ("USERNAME")
If currentUser <> "Akcan" Then
Exit Sub
End If
Dim i As Long
Dim Yol As String
Dim DosyaAdi As String
Dim DosyaAdiUzanti As String
Dim fso As Object
Yol = KitapPath
DosyaAdi = ActiveWorkbook.Name
' Dosya adının uzantısından önceki kısmını alalım
DosyaAdiUzanti = Split(DosyaAdi, ".")(UBound(Split(DosyaAdi, ".")))
DosyaAdi = Left(DosyaAdi, Len(DosyaAdi) - Len(DosyaAdiUzanti) - 1)
Set fso = CreateObject("Scripting.FileSystemObject")
Dim EndFor As Integer
EndFor = 14
If ActiveWorkbook.Name = "Mizan_Mod.xlsm" Then
EndFor = 11
End If
For i = 11 To EndFor
Dim HedefKlasor As String
HedefKlasor = Replace(Yol, "akcan", "t" & i, , , vbTextCompare)
' Hedef klasör yoksa oluştur
If Not fso.FolderExists(HedefKlasor) Then
fso.CreateFolder HedefKlasor
End If
' Yeni dosya adını oluşturuyoruz ve geçersiz karakterleri düzenliyoruz
Dim YeniDosyaAdi As String
YeniDosyaAdi = DosyaAdi & "." & DosyaAdiUzanti
' Hedef klasörde aynı isimde dosya varsa kitabı kapat
'If fso.FileExists(HedefKlasor & "\" & YeniDosyaAdi) Then
'Dim TargetWorkbook As Workbook
'On Error Resume Next
'Set TargetWorkbook = Workbooks(YeniDosyaAdi)
'On Error GoTo 0
' Eğer TargetWorkbook açıksa ve adı ThisWorkbook (kendi dosyanız) ile aynı ise ve uzantısı .xlsm ise kapat
'If Not TargetWorkbook Is Nothing And TargetWorkbook.Name = Left(Application.Caption, Len(Application.Caption) - 8) Then
'TargetWorkbook.Close SaveChanges:=False
'End If
'End If
' Dosyayı kopyala
fso.CopyFile Yol & "\" & DosyaAdi & "." & DosyaAdiUzanti, HedefKlasor & "\" & YeniDosyaAdi
Next i
Set fso = Nothing
Application.ScreenUpdating = True
CreateObject("WScript.Shell").Popup _
"*** Ç a l ı ş m a K i t a b ı K o p y a l a n m ı ş t ı r. ***", 1, "Designed By Özcan Ballıkaya", vbOKOnly + vbExclamation + vbInformation
End Sub