• DİKKAT

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

VBA Kod yardımı

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Merhaba,

Kod: 
Dim Bul As Range
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BE"), Cells(Bul.Row, "BE")).Value = Range("Q29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BF"), Cells(Bul.Row, "BF")).Value = Range("AA29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BG"), Cells(Bul.Row, "BG")).Value = Range("AH29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)

Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BH"), Cells(Bul.Row, "BH")).Value = Range("Q30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BI"), Cells(Bul.Row, "BI")).Value = Range("AA30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BJ"), Cells(Bul.Row, "BJ")).Value = Range("AH30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)

If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BK"), Cells(Bul.Row, "BK")).Value = Range("O34").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BL"), Cells(Bul.Row, "BL")).Value = Range("AJ34").Value

Mevcut kodda " Find(Range("$M$8") " de ki tarihe göre işlem yapmakta. Çoğu zaman M8 hücresi boş olduğunda bile işlem yapıyor. Benim istediğim M8 boş ise, tarih giriniz diye uyarı versin. Kodlamada ne gibi değişiklik yapılması gerekir ?

Teşekkürler,
 
KOdun en başına

if [M8] = "" then
msgbox "M8 boş olamaz, lütfen tarih giriniz!", vbcritical
[M8].select
Else

Satırlarını ve sonuna da


End if

satırını ilave ederek deneyiniz.
 
YUSUF44' Alıntı:
KOdun en başına

if [M8] = "" then
msgbox "M8 boş olamaz, lütfen tarih giriniz!", vbcritical
[M8].select
Else

Satırlarını ve sonuna da


End if

satırını ilave ederek deneyiniz.
Genişletmek için tıkla ...

verdiğiniz kodları ekledim. Uyarıya tamam denildiğinde devamındaki kodlar çalışmasın istiyorum. Tüm Kodlar;

Kod: 
Sub VeriyeGoreKopya()
 'Yazdırma
   ActiveSheet.PageSetup.PrintArea = "$B$3:$AR$61"
   ActiveWindow.SelectedSheets.PrintOut Copies:=2, Collate:=True, _
   IgnorePrintAreas:=False

' Devir
If [M8] = "" Then
MsgBox "Tarih boş olamaz, lütfen tarih giriniz!", vbCritical
[M8].Select
Else

Dim Bul As Range
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BE"), Cells(Bul.Row, "BE")).Value = Range("Q29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BF"), Cells(Bul.Row, "BF")).Value = Range("AA29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BG"), Cells(Bul.Row, "BG")).Value = Range("AH29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)

Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BH"), Cells(Bul.Row, "BH")).Value = Range("Q30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BI"), Cells(Bul.Row, "BI")).Value = Range("AA30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BJ"), Cells(Bul.Row, "BJ")).Value = Range("AH30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)

If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BK"), Cells(Bul.Row, "BK")).Value = Range("O34").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BL"), Cells(Bul.Row, "BL")).Value = Range("AJ34").Value
       


' Temizleme
Range( _
"E15:E22,G15:G22,I15:I22,K15:K22,M15:M22,O15:O22,Q15:Q22,S15:S22,U15:U22,W15:W22,Y15:Y22,AD15:AD22,AF15:AF22,AH15:AH22,AJ15:AJ22,AL15:AL22,AN15:AN22,AP15:AP22,AR15:AR22,M8:Q8,O34,AJ34,M8" _
        ).Select
    Selection.ClearContents
Range("M8").Select
    
MsgBox "Devir Yapıldı...  Tablo Temizlendi...  İşleminiz tamamlanmıştır..!"
End Sub
End If

Teşekkür ederim.
 
Eğer kodlara eklenebilirse: Yazdırırken masa üstünede PDF olarak farklı kaydettirilebilir mi ?

ActiveSheet.PageSetup.PrintArea = "$B$3:$AR$61"
ActiveWindow.SelectedSheets.PrintOut Copies:=2, Collate:=True, _
IgnorePrintAreas:=False
Genişletmek için tıkla ...

Yardımlarınız için teşekkür ederim.
 
End if satırını end Sub satırından önce yazın.
Kodlar çalışmaması için

[M8].select

satırından sonra

goto 10

satıırını ve

End sub satırından önce

10:

satırını ekleyin.

PDF kaydetmeyi bilmiyorum.
 
YUSUF44' Alıntı:
End if satırını end Sub satırından önce yazın.
Kodlar çalışmaması için

[M8].select

satırından sonra

goto 10

satıırını ve

End sub satırından önce

10:

satırını ekleyin.

PDF kaydetmeyi bilmiyorum.
Genişletmek için tıkla ...

Tam istediğim gibi oldu. Teşekkür ederim.
 
Dunya_' Alıntı:
verdiğiniz kodları ekledim. Uyarıya tamam denildiğinde devamındaki kodlar çalışmasın istiyorum. Tüm Kodlar;

Kod: 
Sub VeriyeGoreKopya()
 'Yazdırma
   ActiveSheet.PageSetup.PrintArea = "$B$3:$AR$61"
   ActiveWindow.SelectedSheets.PrintOut Copies:=2, Collate:=True, _
   IgnorePrintAreas:=False

' Devir
If [M8] = "" Then
MsgBox "Tarih boş olamaz, lütfen tarih giriniz!", vbCritical
[M8].Select
Else

Dim Bul As Range
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BE"), Cells(Bul.Row, "BE")).Value = Range("Q29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BF"), Cells(Bul.Row, "BF")).Value = Range("AA29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BG"), Cells(Bul.Row, "BG")).Value = Range("AH29").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)

Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BH"), Cells(Bul.Row, "BH")).Value = Range("Q30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BI"), Cells(Bul.Row, "BI")).Value = Range("AA30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BJ"), Cells(Bul.Row, "BJ")).Value = Range("AH30").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)

If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BK"), Cells(Bul.Row, "BK")).Value = Range("O34").Value
Set Bul = Range("BD:BD").Find(Range("$M$8"), , , xlWhole)
If Not Bul Is Nothing Then Range(Cells(Bul.Row, "BL"), Cells(Bul.Row, "BL")).Value = Range("AJ34").Value
       


' Temizleme
Range( _
"E15:E22,G15:G22,I15:I22,K15:K22,M15:M22,O15:O22,Q15:Q22,S15:S22,U15:U22,W15:W22,Y15:Y22,AD15:AD22,AF15:AF22,AH15:AH22,AJ15:AJ22,AL15:AL22,AN15:AN22,AP15:AP22,AR15:AR22,M8:Q8,O34,AJ34,M8" _
        ).Select
    Selection.ClearContents
Range("M8").Select
    
MsgBox "Devir Yapıldı...  Tablo Temizlendi...  İşleminiz tamamlanmıştır..!"
End Sub
End If

Teşekkür ederim.
Genişletmek için tıkla ...

Hocam; PDF kodunu buldum ancak seçili alan belirtmeyi yapamadım.
Kod: 
'PDF Kaydet
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\Desktop\Raporları" & "\" & [M8] & "  Raporu", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

If [M8] = "" Then
MsgBox "Lütfen Tarih Giriniz!", vbCritical
[M8].Select
GoTo 10
Else
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst