Makroları Birleştirme

ormann · 22 Şubat 2019

İyi günler ;
Ekli iki kodu tek kodda birleştirmek istiyorum.Yardımcı olur musunuz ?
Kod-1

Kod:

Sub Önzizle()
Sheets("rapor").Unprotect 1978
Dim sat As Long
Dim S1 As Worksheet, S2 As Worksheet
On Error Resume Next
Set S1 = Worksheets("ANASAYFA")
Set S2 = Worksheets("RAPOR")

S2.Range("D12") = Replace(Replace(Replace(TextBox1.Value, Chr(13), " "), Chr(32), " "), Chr(9), "         ") 'EMİR
S2.Range("D15") = Replace(Replace(Replace(TextBox2.Value, Chr(13), " "), Chr(32), " "), Chr(9), "         ") 'KONU
S2.Range("D16") = Replace(Replace(Replace(TextBox3.Value, Chr(13), " "), Chr(32), " "), Chr(9), "         ") 'İNCELEME
S2.Range("D17") = Replace(Replace(Replace(TextBox4.Value, Chr(13), " "), Chr(32), " "), Chr(9), "         ") 'SONUÇ
S2.Range("A139") = TextBox7.Value
S2.Range("B27") = ComboBox5.Value
S2.Range("E27") = ComboBox6.Value
S2.Range("J27") = ComboBox7.Value
S2.Range("B28") = ComboBox8.Value
S2.Range("F28") = ComboBox9.Value
S2.Range("J28") = ComboBox10.Value
S2.Range("l18") = TextBox5.Value
Sheets("rapor").Select
Call SatırAyarla ' Module1 deki kodu çalıştırır.

Sheets("rapor").PrintPreview
Sheets("anasayfa").Select
Sheets("rapor").Protect 1978
End Sub

Kod 2

Kod:

Sub Önzile1()
Sheets("rapor").Unprotect 1978
Beep
Application.ScreenUpdating = False
Dim Krt_1 As String, Krt_2 As String
Dim Alan As Range, n1 As Integer, n2 As Integer
Krt_1 = "ORMAN SAYILMAYAN YERLERDEN"
Krt_2 = "ORMAN SAYILAN YERLERDEN"
    For Each Alan In [D16:D17]
        Alan.Font.Bold = 0
        If Alan <> "" Then
            n1 = 1
            n2 = 1
            veri = UCase(Replace(Replace(Alan, "ı", "I"), "i", "İ"))
            Do While n1 > 0
                n1 = InStr(n1, veri, UCase(Krt_1))
                If n1 > 0 Then
                    Alan.Characters(n1, Len(Krt_1)).Font.Bold = 1
                    n1 = n1 + Len(Krt_1)
                End If
            Loop
            Do While n2 > 0
                n2 = InStr(n2, veri, UCase(Krt_2))
                If n2 > 0 Then
                    Alan.Characters(n2, Len(Krt_2)).Font.Bold = 1
                    n2 = n2 + Len(Krt_2)
                End If
            Loop
        End If
    Next Alan
Sheets("rapor").PrintPreview
Application.ScreenUpdating = True
Sheets("rapor").Protect 1978

End Sub

ormann · 22 Şubat 2019

Arkadaşlar konuya yardımcı olur musunuz?

Cengiz Demir · 22 Şubat 2019

Daha detaylı bilgi verirseniz. Belki yardımcı olabilecek bir arkadaş çıkar.

İki kod arasındaki bağ nedir ? İkinci kod, birinci koddaki bir koşul gerçekleşince mi çalışacak ? Birinci kod bitiminde mi çalışacak ? vb.

Bu şekilde, dışarıdan bakan birisi için; o kodlar pek bir anlam ifade etmiyordur.
En azından ben bir bağ ilişki kuramadım o iki kod arasında.

PLİNT · 22 Şubat 2019

Merhaba
Call SatırAyarla makrosu belli değil ama dilerseniz aşağıdaki gibi deneyin

Kod:

Sub Önzizle()
Sheets("rapor").Unprotect 1978
Dim sat As Long
Dim S1 As Worksheet, S2 As Worksheet
On Error Resume Next
Set S1 = Worksheets("ANASAYFA")
Set S2 = Worksheets("RAPOR")

S2.Range("D12") = Replace(Replace(Replace(TextBox1.Value, Chr(13), " "), Chr(32), " "), Chr(9), "         ") 'EMİR
S2.Range("D15") = Replace(Replace(Replace(TextBox2.Value, Chr(13), " "), Chr(32), " "), Chr(9), "         ") 'KONU
S2.Range("D16") = Replace(Replace(Replace(TextBox3.Value, Chr(13), " "), Chr(32), " "), Chr(9), "         ") 'İNCELEME
S2.Range("D17") = Replace(Replace(Replace(TextBox4.Value, Chr(13), " "), Chr(32), " "), Chr(9), "         ") 'SONUÇ
S2.Range("A139") = TextBox7.Value
S2.Range("B27") = ComboBox5.Value
S2.Range("E27") = ComboBox6.Value
S2.Range("J27") = ComboBox7.Value
S2.Range("B28") = ComboBox8.Value
S2.Range("F28") = ComboBox9.Value
S2.Range("J28") = ComboBox10.Value
S2.Range("l18") = TextBox5.Value
Sheets("rapor").Select
Call SatırAyarla ' Module1 deki kodu çalıştırır.
S2.Activate
Application.ScreenUpdating = False
Dim Krt_1 As String, Krt_2 As String
Dim Alan As Range, n1 As Integer, n2 As Integer
Krt_1 = "ORMAN SAYILMAYAN YERLERDEN"
Krt_2 = "ORMAN SAYILAN YERLERDEN"
    For Each Alan In S2.[D16:D17]
        Alan.Font.Bold = 0
        If Alan <> "" Then
            n1 = 1
            n2 = 1
            veri = UCase(Replace(Replace(Alan, "ı", "I"), "i", "İ"))
            Do While n1 > 0
                n1 = InStr(n1, veri, UCase(Krt_1))
                If n1 > 0 Then
                    Alan.Characters(n1, Len(Krt_1)).Font.Bold = 1
                    n1 = n1 + Len(Krt_1)
                End If
            Loop
            Do While n2 > 0
                n2 = InStr(n2, veri, UCase(Krt_2))
                If n2 > 0 Then
                    Alan.Characters(n2, Len(Krt_2)).Font.Bold = 1
                    n2 = n2 + Len(Krt_2)
                End If
            Loop
        End If
    Next Alan
    Application.ScreenUpdating = True

Sheets("rapor").PrintPreview
Dim SayfaAdedi As Integer
    
    SayfaAdedi = Application.InputBox("YAZDIRILACAK SAYFA ADEDİNİ GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 1, Type:=2)
If Not SayfaAdedi = 0 Then Sheets("rapor").PrintOut From:=1, To:=1, Copies:=SayfaAdedi



Sheets("anasayfa").Select
Sheets("rapor").Protect 1978
End Sub

ormann · 22 Şubat 2019

Çok teşekkür ederim.Gayet güzel çalışır.Ellerinize sağlık

ormann · 22 Şubat 2019

Sayın Plint
1.Kodun sonuna aşağıdaki kodu ekleyebilir misiniz ?

Kod:

Sub Yazdır1()
Sheets("rapor").Unprotect 1978
Beep
Application.ScreenUpdating = False
Dim Krt_1 As String, Krt_2 As String
Dim Alan As Range, n1 As Integer, n2 As Integer
Krt_1 = "ORMAN SAYILMAYAN YERLERDEN"
Krt_2 = "ORMAN SAYILAN YERLERDEN"
    For Each Alan In [D16:D17]
        Alan.Font.Bold = 0
        If Alan <> "" Then
            n1 = 1
            n2 = 1
            veri = UCase(Replace(Replace(Alan, "ı", "I"), "i", "İ"))
            Do While n1 > 0
                n1 = InStr(n1, veri, UCase(Krt_1))
                If n1 > 0 Then
                    Alan.Characters(n1, Len(Krt_1)).Font.Bold = 1
                    n1 = n1 + Len(Krt_1)
                End If
            Loop
            Do While n2 > 0
                n2 = InStr(n2, veri, UCase(Krt_2))
                If n2 > 0 Then
                    Alan.Characters(n2, Len(Krt_2)).Font.Bold = 1
                    n2 = n2 + Len(Krt_2)
                End If
            Loop
        End If
    Next Alan
Dim SayfaAdedi As Integer
    
    SayfaAdedi = Application.InputBox("YAZDIRILACAK SAYFA ADEDİNİ GİRİNİZ ?", "KOPYA SAYISI GİRİŞİ !!!!", 1, Type:=2)
If Not SayfaAdedi = 0 Then Sheets("rapor").PrintOut From:=1, To:=1, Copies:=SayfaAdedi
Application.ScreenUpdating = True
Sheets("rapor").Protect 1978

End Sub

PLİNT · 22 Şubat 2019

Biçimlendirme "Rapor" sayfası için sanırım, o bölüm zaten var, yazdırma satırları; yukarıdaki kodlara eklendi deneyiniz

ormann · 22 Şubat 2019

Teşekkür ederim