• DİKKAT

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

Klasör içinde mükerrer dosya

A

acolkesen1

Katılım
5 Aralık 2007
Mesajlar
635
Excel Vers. ve Dili
Office 2007
Merhabalar,
Aşağıda yazılı kodlarla bir excel dosyasını D içerisinedeki "yedek" klasörüne Sayfa1!a1 de yazılı isimle kaydediyorum.Ancak aynı isimde bir başka dosya varsa uyarı verecek kodları bir türlü yapamadım.Çalışma kitabı içinde mükerrer sayfa adı olması durumunda çalışan kodları uyarlamaya çalıştım ama olmadı. Yardımcı olabilirmisiniz? İlgilenen arkadaşlara teşekkür ederim.

Sub Kayıt()
??????
ActiveWorkbook.SaveAs "D:\yedek\" & [Sayfa1!a1]
End Sub
 
Aşağıdaki gibi kodunuzu değiştiriniz.

Kod: 
Sub Kayıt()
If Dir("D:\yedek\" & [Sayfa1!a1]) = "" Then
   MsgBox "Aynı isimli dosya var"
Else
   ActiveWorkbook.SaveAs "D:\yedek\" & [Sayfa1!a1]
End If
End Sub
 
Değerli Ferhat bey, daha önce de yardımlarınızı esirgememiştiniz. İlginizden dolayı çok teşekkür ederim.Sağlıcakla kalın.
 
Sayın Ferhat bey, yazdığınız kodları olması gereken yerlere yerleştirdim ama aynı dosya olmasa da uyarı mesajı veriyor. Acaba gözden kaçırdığım bir şey mi var.? Ben fazla oyalamamak için yardımlarınızla hazırladığım kodların bir bölümünü göndermiştim. Tamamı üzerinde daha sağlıklı olacak galiba. kodlar aşağıdaki gibi:
Sub devir()
ActiveSheet.Unprotect
Range("B4").Select
Selection.Locked = True
Selection.FormulaHidden = False
Range("B10").Select
Selection.Locked = True
Selection.FormulaHidden = False
If MsgBox("BİLGİLER KAYDEDİLİP PROGRAM KAPATILACAK. DEVAM ETMEK İSTİYOR MUSUNUZ?", vbYesNo, "") = vbNo Then Exit Sub
For i = 1 To Worksheets.Count
If Range("B10").Value = "" Then
MsgBox "DEVİR YAPACAĞINIZ YILI YAZINIZ.."
Exit Sub
End If
Next i

If IsDate(Range("B4")) = False Then
MsgBox "DEVİR TARİHİNİ BELİRLEYİNİZ!", vbCritical, "UYARI"
Exit Sub
Else

End If
If Date < Range("B4") Then
MsgBox Range("B4") & " TAR&#304;H&#304;NDEN &#214;NCE DEV&#304;R YAPAMAZSINIZ", vbCritical, "UYARI"

Exit Sub
Else
M&#252;kerrer kay&#305;t uyar&#305;s&#305; verecek kodlar bu sat&#305;ra yaz&#305;lacak
MsgBox "BU &#304;S&#304;MDE B&#304;R DOSYA VAR, BA&#350;KA &#304;S&#304;MLE KAYIT YAPINIZ!", vbCritical, "UYARI"
Exit Sub
End If
Sheets("B&#304;LAN&#199;O").Select
Cells.Select
ActiveSheet.Unprotect
Cells.Select
Selection.Copy
Sheets("DEV&#304;R").Select
Cells.Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets("BEKLEY&#304;N&#304;Z").Select

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "D:\APARTMAN\" & ([KURULUMSAYFASI!a10] & [KURULUMSAYFASI!b10])
Application.Quit
End Sub
 
Son düzenleme:
Aşağıdaki gibi deneyiniz.

Kod: 
Sub devir()
....[/COLOR]
[COLOR=dimgray]....[/COLOR]
[COLOR=dimgray]....[/COLOR]
[COLOR=silver][COLOR=dimgray]If Date < Range("B4") Then
   MsgBox Range("B4") & " TARİHİNDEN ÖNCE DEVİR YAPAMAZSINIZ", vbCritical, "UYARI"
   Exit Sub
Else[/COLOR]
[/COLOR][COLOR=seagreen][B]   'Mükerrer kayıt uyarısı verecek kodlar bu satıra yazılacak
[/B][/COLOR][COLOR=red]   If Dir("D:\yedek\" & [Sayfa1!a1]) = "" Then
      MsgBox "BU İSİMDE BİR DOSYA VAR, BAŞKA İSİMLE KAYIT YAPINIZ!", vbCritical, "UYARI"
      Exit Sub
   Else
      ActiveWorkbook.SaveAs "D:\yedek\" & [Sayfa1!a1]
   End If
[/COLOR][COLOR=dimgray]End If
Sheets("BİLANÇO").Select
Cells.Select
[/COLOR]...
...
...
End Sub
 
Say&#305;n Pazar&#231;evirdi, yard&#305;mlar&#305;n&#305;z i&#231;in te&#351;ekk&#252;r ederim ama olmad&#305; yine.
Makrodan k&#305;rm&#305;z&#305; olan k&#305;sm&#305; &#231;&#305;kar&#305;nca aky&#305;t yap&#305;yor,(eskisinin &#252;zerine tabii) aksi halde kay&#305;t yap&#305;lan klas&#246;r i&#231;inde ayn&#305; isimde bir dosya olamad&#305;&#287;&#305; halde uyar&#305; veriyor. Nerde hata yap&#305;yorum &#231;&#246;zemedim..Makronun son hali a&#351;a&#287;&#305;daki gibidir.

Sub devir()
'
' devir Makro
'
'

'

ActiveSheet.Unprotect
Range("B4").Select
Selection.Locked = True
Selection.FormulaHidden = False
Range("B10").Select
Selection.Locked = True
Selection.FormulaHidden = False
If MsgBox("B&#304;LG&#304;LER KAYDED&#304;L&#304;P PROGRAM KAPATILACAK. DEVAM ETMEK &#304;ST&#304;YOR MUSUNUZ?", vbYesNo, "") = vbNo Then Exit Sub
For i = 1 To Worksheets.Count
If Range("B10").Value = "" Then
MsgBox "DEV&#304;R YAPACA&#286;INIZ YILI YAZINIZ.."
Exit Sub
End If
Next i

If IsDate(Range("B4")) = False Then
MsgBox "DEV&#304;R TAR&#304;H&#304;N&#304; BEL&#304;RLEY&#304;N&#304;Z!", vbCritical, "UYARI"
Exit Sub
Else

End If
If Date < Range("B4") Then
MsgBox Range("B4") & " TAR&#304;H&#304;NDEN &#214;NCE DEV&#304;R YAPAMAZSINIZ", vbCritical, "UYARI"
Exit Sub
Else

If Dir("D:\APARTMAN\" & ([KURULUMSAYFASI!a10] & [KURULUMSAYFASI!b10])) = "" Then
MsgBox "BU &#304;S&#304;MDE B&#304;R DOSYA VAR, BA&#350;KA &#304;S&#304;MLE DEV&#304;R YAPINIZ!", vbCritical, "UYARI"
Exit Sub
Else
End If
Sheets("B&#304;LAN&#199;O").Select
Cells.Select
Selection.Copy
Sheets("DEV&#304;R").Select
Cells.Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets("BEKLEY&#304;N&#304;Z").Select
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "D:\APARTMAN\" & ([KURULUMSAYFASI!a10] & [KURULUMSAYFASI!b10])
Application.Quit
End Sub
 
A&#351;a&#287;&#305;daki &#351;ekilde deneyin.Olacak.:cool:
Kod: 
If Dir("D:\APARTMAN\" & ([KURULUMSAYFASI!a10] & [KURULUMSAYFASI!b10])) [COLOR="Red"][B]<>[/B][/COLOR] "" Then
MsgBox "BU &#304;S&#304;MDE B&#304;R DOSYA VAR, BA&#350;KA &#304;S&#304;MLE DEV&#304;R YAPINIZ!", vbCritical, "UYARI"
Exit Sub
Else
 
If Dir("D:\APARTMAN\" & ([KURULUMSAYFASI!a10] & [KURULUMSAYFASI!b10])) <> "" Then
MsgBox "BU &#304;S&#304;MDE B&#304;R DOSYA VAR, BA&#350;KA &#304;S&#304;MLE DEV&#304;R YAPINIZ!", vbCritical, "UYARI"
Exit Sub
Else

B&#246;l&#252;m&#252;nde "=" k&#305;sm&#305;n&#305; "<>" olarak de&#287;i&#351;tirirmisiniz?
 
Sevgili Evren Gizlen ve ECYavuz , her ikinize de te&#351;ekk&#252;r ederim &#252;stadlar...Sizin i&#231;in k&#252;&#231;&#252;k ama benim i&#231;in &#246;nemli olan yard&#305;mlar&#305;n&#305;z i&#231;in....Ama daha da &#246;nemlisi her&#351;eyi sadece yard&#305;mc&#305; olmak ad&#305;na yap&#305;yor olman&#305;z.. &#304;yi ki vars&#305;n&#305;z..
 
acolkesen1' Alıntı:
Sevgili Evren Gizlen ve ECYavuz , her ikinize de teşekkür ederim üstadlar...Sizin için küçük ama benim için önemli olan yardımlarınız için....Ama daha da önemlisi herşeyi sadece yardımcı olmak adına yapıyor olmanız.. İyi ki varsınız..
Genişletmek için tıkla ...
Rica ederim.
iiyi çalışmalar.:cool:
 
De&#287;erli Arkada&#351;lar, yukar&#305;daki kodlarldaki son d&#252;zeltmeden sonra dosya kaydedilmeye ba&#351;lad&#305; ama bu sefer de klas&#246;r i&#231;inde ayn&#305; isimde dosya olmas&#305;na ra&#287;men &#252;zerine kaydediyor. Daha &#246;nceki sorun m&#252;kerrer dosya olamamas&#305;na ra&#287;men m&#252;kerrer uyar&#305;s&#305; veriyor ve kaydetmiyordu. Kay&#305;t yapmaya ba&#351;lay&#305;nca sorun &#231;&#246;z&#252;ld&#252; sanm&#305;&#351;t&#305;m.Fark&#305;nda olmadan bir de&#287;i&#351;iklik mi yapt&#305;m bilemiyorum.. Kodlara bir kere daha bakabilirmisiniz acaba?

Sub devir()
'
'
'
'

'

ActiveSheet.Unprotect
Range("B4").Select
Selection.Locked = True
Selection.FormulaHidden = False
Range("B10").Select
Selection.Locked = True
Selection.FormulaHidden = False
If MsgBox("B&#304;LG&#304;LER KAYDED&#304;L&#304;P PROGRAM KAPATILACAK. DEVAM ETMEK &#304;ST&#304;YOR MUSUNUZ?", vbYesNo, "") = vbNo Then Exit Sub
For i = 1 To Worksheets.Count
If Range("B10").Value = "" Then
MsgBox "DEV&#304;R YAPACA&#286;INIZ YILI YAZINIZ.."
Exit Sub
End If
Next i

If IsDate(Range("B4")) = False Then
MsgBox "DEV&#304;R TAR&#304;H&#304;N&#304; BEL&#304;RLEY&#304;N&#304;Z!", vbCritical, "UYARI"
Exit Sub
Else

End If
If Date < Range("B4") Then
MsgBox Range("B4") & " TAR&#304;H&#304;NDEN &#214;NCE DEV&#304;R YAPAMAZSINIZ", vbCritical, "UYARI"
Exit Sub
Else

If Dir("D:\APARTMAN\" & ([KURULUMSAYFASI!a10] & [KURULUMSAYFASI!b10])) <> "" Then
MsgBox "BU &#304;S&#304;MDE B&#304;R DOSYA VAR, BA&#350;KA &#304;S&#304;MLE DEV&#304;R YAPINIZ!", vbCritical, "UYARI"
Exit Sub
Else

End If
Sheets("B&#304;LAN&#199;O").Select
Cells.Select
Selection.Copy
Sheets("DEV&#304;R").Select
Cells.Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets("BEKLEY&#304;N&#304;Z").Select

ActiveWorkbook.SaveAs "D:\APARTMAN\" & ([KURULUMSAYFASI!a10] & [KURULUMSAYFASI!b10])
End If
Application.Quit
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst