Makronun İçinde Uyarı Mesajı Ekleme

[asiiiruzgar]

Arkadaşlar Üzerinde Çalışmış Olduğum Bir Excell Sayfası var.
veri girişi yapıyoruz kaydet butonuna tıkladığım an ilgili yer nereyse oraya kaydediyor.
Yani.. Sayfada Seçmiş Olduğumuz F3 Hücresi neyse Onun O adında muhakkak z diskinde hastane kayıt dosyaı altından o hastanelerin adında klasörler var f3 hücresinde hangi hastane seçilmişse o hastane klasörünün içine giriyor ve j8 hücresinde genel toplam neyse o isimle kaydediyor.
benim isteğim bazen dalgınlıkla olsa kaydetmesi gereken dosya yolunu bulamıyor ama kaydet tıkladığımız an bir hata vermiyor bende kaydettiğini sanarak o veri girişinden çıkıyorum kaydet makrosu nun içine bir mesaj eklesek uyarı mesajı şu şekilde sizler daha iyi bilirsiniz nereye olacağını
1-) Kaydet Butonuna tıkladığım an eğer dosya adı varsa kaydetsin ama bana " girmiş olduğunuz veri gerekli dosya içine kaydedildi "
2- ) Kaydet butonuna tıkladğım an eğer dosya adı yoksa kaydedeöiyeceğinden " dosya yolu bulunamaıştır " diye mesaj vermesini istiyorum.

 

[hsayar]

Arkadaşlar Üzerinde Çalışmış Olduğum Bir Excell Sayfası var.
veri girişi yapıyoruz kaydet butonuna tıkladığım an ilgili yer nereyse oraya kaydediyor.
Yani.. Sayfada Seçmiş Olduğumuz F3 Hücresi neyse Onun O adında muhakkak z diskinde hastane kayıt dosyaı altından o hastanelerin adında klasörler var f3 hücresinde hangi hastane seçilmişse o hastane klasörünün içine giriyor ve j8 hücresinde genel toplam neyse o isimle kaydediyor.
benim isteğim bazen dalgınlıkla olsa kaydetmesi gereken dosya yolunu bulamıyor ama kaydet tıkladığımız an bir hata vermiyor bende kaydettiğini sanarak o veri girişinden çıkıyorum kaydet makrosu nun içine bir mesaj eklesek uyarı mesajı şu şekilde sizler daha iyi bilirsiniz nereye olacağını
1-) Kaydet Butonuna tıkladığım an eğer dosya adı varsa kaydetsin ama bana " girmiş olduğunuz veri gerekli dosya içine kaydedildi "
2- ) Kaydet butonuna tıkladğım an eğer dosya adı yoksa kaydedeöiyeceğinden " dosya yolu bulunamaıştır " diye mesaj vermesini istiyorum.

Sub FolderExistsArsiv()
Dim TargetFolder As String
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
'Set s4 = Sheets("Sayfa4")
Set fs = CreateObject("Scripting.FileSystemObject")
a = WorksheetFunction.Text(s1.Cells(1, 1), "yyyy")
b = WorksheetFunction.Text(s1.Cells(1, 1), "mmyyyy")
k_yol = ThisWorkbook.Path
k_ad = ThisWorkbook.Name
tarih = s1.Cells(1, 1)

'---------------Klasör varmı yok mu kontrol et ? yoksa oluştur
yol = ThisWorkbook.Path & "\" ' mevcut çalışma kitabının olduğu ve alt klasör açılacak yol
TargetFolder = yol & a         ' Açılacak klasör adı ile birleşimi
If Not fs.FolderExists(TargetFolder) Then        'KONTROL
ChDir yol: MkDir a: MsgBox a & " Klasörü oluşturuldu.!"  'klasöre git, oluşturma mesajı ver
GoTo CalismasayfasıKontrol
Else
MsgBox a & " Klasörü var!"   'var mesajı var
End If

'--------------->>>>>>
Exit Sub
CalismasayfasıKontrol:
MsgBox "CalismasayfasıKontrol-e hoşgeldiniz"
'farklı kaydet
    ActiveWorkbook.SaveAs Filename:= _
    yol & a & "\" & b & ".xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
        farklıkaydet  denedim, ama tekrar dosya adı sordu
'Aynı dosyaya Dön
    ChDir k_yol
    Workbooks.Open Filename:= _
        k_yol & "\" & k_ad

'farklı kaydedileni kapat
    ck_adi = b & ".xls": Windows(ck_adi).Close
'...........................
End Sub

Kendim için forumdaki arkadaşların desteği ile hazırlamış olduğum kodlar yukarıda belirtilmiştir...
Yalnız sayfa korumalı olduğu için sizin sayfanızda deneyemedim.
Parolanızı söylerseniz naçizane birşeyler yapmaya çalışırım

 

[hsayar]

yada en basitinden

sub kaydet () 
On Error Resume Next

kaldırırsanız makronuzun hatalı olduğunu anlarsanız

 

[hsayar]

Sub kaydet_hsr()

Dim TargetFolder As String
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
Set fs = CreateObject("Scripting.FileSystemObject")
Dim dosya As String
dosya = s1.Range("J8")
dizin = s1.Range("f3")
hedefdizin = "D:\HASTANE KAYIT DOSYASI\" & dizin & "\"
'------------------------<<<de&#287;i&#351;kenler<<<<<
'------------------------>>>Dizin varm&#305;?>>>>>
If Not fs.FolderExists(hedefdizin) Then        'KONTROL
MsgBox hedefdizin & "  Bilgisayar&#305;n&#305;zda Bulunmamaktad&#305;r!"
Else
MsgBox hedefdizin & "\" & dosya & ".XLS" & " Ad&#305;nda &#231;al&#305;&#351;ma sayfas&#305; kopyalanacakt&#305;r.", , "bilgi-hsr"
   [color=Red] 
   ChDir hedefdizin
    s1.Select
    ActiveWorkbook.SaveAs Filename:= _
    hedefdizin & "\" & dosya & ".XLS", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False [/color]

End If
End Sub

kırmızı ile yazılı olanda hata veriyor her nedense
hedef dizin D:\HASTANE KAYIT DOSYASI\" & dizin & "\" ise
hedefdizin & "\" & dosya & ".XLS" ise yazınca
D:\HASTANE KAYIT DOSYASI\" & dizin & "\" & "\" & dosya & ".XLS
haline geliyorda ondan \\ ile ulaşılan klasör olurmu? olmaz küçük hata büyük sonuç


f3= İDH
j8= 100000 ve j8=TEST denedim ama sorun aynı

 

[asiiiruzgar]

koruma yok

koruma yok biliyorum ama koruma varsada muhakka şifresi 22646 dırrr
bu arada kaydet makrosuna hiç bir zarar vermeden kaydet makrosunun içine yapılırsa sevinirim sadece mesaj bölümü

 

[hsayar]

Sub kaydet()
Dim TargetFolder As String
Dim s1 As Worksheet
Set s1 = Sheets("HASTANE LİSTESİ")
Set fs = CreateObject("Scripting.FileSystemObject")
Dim dosya As String
k_yol = ThisWorkbook.Path
k_ad = ThisWorkbook.Name
dosya = s1.Range("J8")
dizin = s1.Range("f3")
hedefdizin = "d:\HASTANE KAYIT DOSYASI\" & dizin & "\"
'------------------------<<<değişkenler<<<<<
'------------------------>>>Dizin varmı?>>>>>
If Not fs.FolderExists(hedefdizin) Then        'KONTROL
MsgBox hedefdizin & "  Bilgisayarınızda Bulunmamaktadır!"
Else
MsgBox hedefdizin & dosya & " Adında çalışma sayfası kopyalanacaktır.", , "bilgi-hsr"
    '>>>>>>>farklı kaydet
    ActiveWorkbook.SaveAs Filename:=hedefdizin & dosya & ".XLS"
    MsgBox "Tüm Bilgiler İlgili Tablolara Aktarıldı. Ahmet SAHAN"
    Application.ScreenUpdating = False
    '>>>>>>>>boş listeye dön
    ChDir k_yol
    Workbooks.Open Filename:= _
    k_yol & "\" & k_ad
    '>>>>>>>>farklı kaydedileni kapat
    MsgBox dosya & " kapatılacaktır"
    Windows(dosya & ".XLS").Close
'...........................
End If
End Sub

Umarım işinize yarar.... sonunda faydalı olamaya başlayacam galiba

Çalışma kitabınızı açın
Alt + f11 ile vba düzenleyicisne gidin

Sub Kaydeti silip yukarıdaki kodları çalıştırın
daha sonra
Sub Kaydet altında hedefdizindeki D:\ yi Z:\ yapın

Kolay gelsin

 

[hsayar]

koruma yok biliyorum ama koruma varsada muhakka şifresi 22646 dırrr
bu arada kaydet makrosuna hiç bir zarar vermeden kaydet makrosunun içine yapılırsa sevinirim sadece mesaj bölümü

galiba edirne/meriç in bir beldesinde görev yapıyorsunuz
bewn ipsaladanım