VBA Kod yardımı

[Mehmet Sait]

Merhbalar,

Aşağıda ki kodlar ile P17 sorgulama işlemini yaptırıyorum. Ancak sorgulama işlemini ikinci sayfada (D7:AF18) hücrelerini sorgulatmak zorundayım. İkinci sayfada sorgulama yaptıktan sonra devam butonu ile işlemin sonlandırılması mümkün mü ?

Yardımlarınız için teşekkür ederim.

Sub Devir()

If [P17] = "" Then
MsgBox "Lütfen Tarih Giriniz!", vbInformation, ""
Range("P17").Select
GoTo 10
Else

ŞİFRE = "12345"
cvp = InputBox("ŞİFRE GİRİNİZ", "FEDEAL")
If cvp = ŞİFRE Then

Range("P17").Select
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'............ KODLARIM

output = MsgBox("KAYIT YERİNİ SEÇİN", vbInformation)
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
   With fd
      .AllowMultiSelect = False
      If .Show = True Then
        pathSelected = .SelectedItems(1)
      End If
   End With
   If pathSelected = 0 Then
    output = MsgBox("Kayıt Klasörünü Seçin !!", vbCritical)
    GoTo Line1
   End If
Sheets("Devir").Select
    Range("D1").Select
    ChDir pathSelected
ActiveWorkbook.SaveAs Filename:=Selection.Value, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False


'Sheets("sayfa2").Select
'Range("a1").Select


    ActiveWorkbook.Save
    MsgBox "...Dosyanız Oluşturuldu..."
Line1:

  


MsgBox "MAKROLAR ÇALIŞTI"
Else
MsgBox "ŞİFRE YANLIŞ"
End If
10:
End If


Application.Calculation = xlAutomatic

End Sub

 

[YUSUF44]

Örnek dosya paylaşır mısınız?

 

[Mehmet Sait]

Örnek dosya paylaşır mısınız?

Merhaba,
Dosya çok büyük olduğundan sadece işlem yapmak istediğim iki sayfayı örnek dosyasına ekledim.
Dosya Linki : https://dosya.co/bhh9mdngeyit/Kitap1.xlsm.html

Telekkür ederim

 

[YUSUF44]

Dosyanızdaki makroyu çalıştırınca masaüstünde bulunan son aşama isimli dosyayı arıyor ve bulamadığı için işlem yapmıyor.

Ancak sorgulama işlemini ikinci sayfada (D7:AF18) hücrelerini sorgulatmak zorundayım. İkinci sayfada sorgulama yaptıktan sonra devam butonu ile işlemin sonlandırılması mümkün mü ?

Burda tam olarak neyi nasıl yapmak istiyorsunuz?

 

[Mehmet Sait]

Dosyanızdaki makroyu çalıştırınca masaüstünde bulunan son aşama isimli dosyayı arıyor ve bulamadığı için işlem yapmıyor.



Burda tam olarak neyi nasıl yapmak istiyorsunuz?

(D7:AF18) hücrelerinde mutlaka tarih olmalı o yüzden tüm tarihlerin girilmesi zorunlu olması için devam etmemesi gerekmekte..

İndir Kitap1

Dosyayı indir Kitap1

dosya.co

 

[YUSUF44]

Anladığım kadarıyla aşağıdaki kodları dener misiniz?

Sub Devir()
If [P17] = "" Then
    MsgBox "Lütfen Tarih Giriniz!", vbInformation, "MSC"
    Range("P17").Select
    GoTo 10
ElseIf WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[D7:D18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[G7:G18]) > 0 _
    Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[J7:J18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[M7:M18]) > 0 _
    Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[P7:P18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[S7:S18]) > 0 _
    Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[V7:V18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[Y7:Y18]) > 0 _
    Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[AB7:AB18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[AE7:AE18]) > 0 Then
        MsgBox "Hafta Tarihlerini Giriniz!", vbInformation, "MSC"
        Sheets("Hafta_Tarihleri").Activate
        Sheets("Hafta_Tarihleri").[D7].Select
        GoTo 10
Else
    ŞİFRE = "12345"
    cvp = InputBox("ŞİFRE GİRİNİZ", "FEDEAL")
    If cvp = ŞİFRE Then
        Range("P17").Select
        Selection.Copy
        Range("B1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        Range("P17").Select

'Devir Kodları
'Kaydetmek...................
'Sub Düğme11_Tıklat()
    output = MsgBox("KAYIT YERİNİ SEÇİN", vbInformation)
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .AllowMultiSelect = False
        If .Show = True Then
            pathSelected = .SelectedItems(1)
        End If
    End With
    If pathSelected = 0 Then
        output = MsgBox("Kayıt Klasörünü Seçin !!", vbCritical)
        GoTo Line1
    End If
    Sheets("Devir").Select
    Range("D1").Select
    ChDir pathSelected
    ActiveWorkbook.SaveAs Filename:=Selection.Value, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Save
    MsgBox "...Dosyanız Oluşturuldu..."
Line1:
    MsgBox "MAKROLAR ÇALIŞTI"
    Else
        MsgBox "ŞİFRE YANLIŞ"
    End If
10:
End If

Application.Calculation = xlAutomatic

End Sub

 

[Mehmet Sait]

Anladığım kadarıyla aşağıdaki kodları dener misiniz?

Sub Devir()
If [P17] = "" Then
    MsgBox "Lütfen Tarih Giriniz!", vbInformation, "MSC"
    Range("P17").Select
    GoTo 10
ElseIf WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[D7:D18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[G7:G18]) > 0 _
    Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[J7:J18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[M7:M18]) > 0 _
    Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[P7:P18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[S7:S18]) > 0 _
    Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[V7:V18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[Y7:Y18]) > 0 _
    Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[AB7:AB18]) > 0 Or WorksheetFunction.CountBlank(Sheets("Hafta_Tarihleri").[AE7:AE18]) > 0 Then
        MsgBox "Hafta Tarihlerini Giriniz!", vbInformation, "MSC"
        Sheets("Hafta_Tarihleri").Activate
        Sheets("Hafta_Tarihleri").[D7].Select
        GoTo 10
Else
    ŞİFRE = "12345"
    cvp = InputBox("ŞİFRE GİRİNİZ", "FEDEAL")
    If cvp = ŞİFRE Then
        Range("P17").Select
        Selection.Copy
        Range("B1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        Range("P17").Select

'Devir Kodları
'Kaydetmek...................
'Sub Düğme11_Tıklat()
    output = MsgBox("KAYIT YERİNİ SEÇİN", vbInformation)
    Dim fd As Office.FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .AllowMultiSelect = False
        If .Show = True Then
            pathSelected = .SelectedItems(1)
        End If
    End With
    If pathSelected = 0 Then
        output = MsgBox("Kayıt Klasörünü Seçin !!", vbCritical)
        GoTo Line1
    End If
    Sheets("Devir").Select
    Range("D1").Select
    ChDir pathSelected
    ActiveWorkbook.SaveAs Filename:=Selection.Value, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWorkbook.Save
    MsgBox "...Dosyanız Oluşturuldu..."
Line1:
    MsgBox "MAKROLAR ÇALIŞTI"
    Else
        MsgBox "ŞİFRE YANLIŞ"
    End If
10:
End If

Application.Calculation = xlAutomatic

End Sub

Teşekkür ederim. İstediğim gibi oldu ancak hafta tarihlerini girdikten sonra devam etmesi için "Devir" sayfasına geri dönmeden nasıl devam ettirebilirim. Hafta tarihleri sayfasında bir butonla da olabilir.

 

[YUSUF44]

Diğer sayfadaki düğmeye istediğiniz sayfaya kopyalayarak çalıştırabilirsiniz ama bunun için öncelikle makronun başına asıl sayfanızı açacak satır eklemelisiniz. Yanlış hatırlamıyorsam o sayfanın adı "Devir"di. Sub satırından sonra

Sheets("Devir").Activate

Satırını eklemelisiniz.

 

[Mehmet Sait]

Diğer sayfadaki düğmeye istediğiniz sayfaya kopyalayarak çalıştırabilirsiniz ama bunun için öncelikle makronun başına asıl sayfanızı açacak satır eklemelisiniz. Yanlış hatırlamıyorsam o sayfanın adı "Devir"di. Sub satırından sonra

Sheets("Devir").Activate

Satırını eklemelisiniz.

Teşekkür ederim.