• DİKKAT

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

Aynı sayfada iki ayrı makroyu çalıştırmak

  • Konbuyu başlatan Konbuyu başlatan maudet
  • Başlangıç tarihi Başlangıç tarihi
M

maudet

Katılım
16 Ocak 2014
Mesajlar
4
Excel Vers. ve Dili
İngilizce 2010
Merhaba, elimde iki tane makro var. Bunların aynı sayfada aynı anda çalışmasını nasıl sağlayabilirim? Ya da iki makroyu birleştirip tek bir makro üretebilir miyim?

I. MAKRO

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$B$2" <> Empty Then CommandButton1_Click
End Sub
Private Sub CommandButton1_Click()
S1 = "THP"
Range("A14:G65536").ClearContents
sat = 14
For i = 2 To Sheets(S1).[A65536].End(3).Row
If Range("B2") = Sheets(S1).Cells(i, "A") Then
'Cells(sat, "A") = sat - 11
sat = Range("A65536").End(xlUp).Row + 1
Cells(sat, "A") = Sheets(S1).Cells(i, "A")
Cells(sat, "B") = Sheets(S1).Cells(i, "B")
Cells(sat, "C") = Sheets(S1).Cells(i, "C")
Cells(sat, "D") = Sheets(S1).Cells(i, "D")
Cells(sat, "E") = Sheets(S1).Cells(i, "E")
Cells(sat, "F") = Sheets(S1).Cells(i, "F")
Cells(sat, "G") = Sheets(S1).Cells(i, "G")
sat = sat + 1
Else: End If
Next i

II.MAKRO

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$B$2" <> Empty Then CommandButton1_Click
End Sub
Private Sub CommandButton1_Click()
S1 = "KSOZI"
Range("J14:L65536").ClearContents
sat = 14
For i = 2 To Sheets(S1).[A65536].End(3).Row
If Range("B2") = Sheets(S1).Cells(i, "A") Then
'Cells(sat, "A") = sat - 11
sat = Range("J65536").End(xlUp).Row + 1
Cells(sat, "J") = Sheets(S1).Cells(i, "F")
Cells(sat, "K") = Sheets(S1).Cells(i, "I")
Cells(sat, "L") = Sheets(S1).Cells(i, "H")
sat = sat + 1
Else: End If
Next i
End Sub
 
Denermisiniz.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$B$2" <> Empty Then CommandButton1_Click
End Sub
Private Sub CommandButton1_Click()
S1 = "THP"
Range("A14:G65536").ClearContents
sat = 14
For i = 2 To Sheets(S1).[A65536].End(3).Row
If Range("B2") = Sheets(S1).Cells(i, "A") Then
'Cells(sat, "A") = sat - 11
sat = Range("A65536").End(xlUp).Row + 1
Cells(sat, "A") = Sheets(S1).Cells(i, "A")
Cells(sat, "B") = Sheets(S1).Cells(i, "B")
Cells(sat, "C") = Sheets(S1).Cells(i, "C")
Cells(sat, "D") = Sheets(S1).Cells(i, "D")
Cells(sat, "E") = Sheets(S1).Cells(i, "E")
Cells(sat, "F") = Sheets(S1).Cells(i, "F")
Cells(sat, "G") = Sheets(S1).Cells(i, "G")
sat = sat + 1
Else: End If
Next i
CommandButton2_Click
End Sub
Private Sub CommandButton2_Click()
S1 = "KSOZI"
Range("J14:L65536").ClearContents
sat = 14
For i = 2 To Sheets(S1).[A65536].End(3).Row
If Range("B2") = Sheets(S1).Cells(i, "A") Then
'Cells(sat, "A") = sat - 11
sat = Range("J65536").End(xlUp).Row + 1
Cells(sat, "J") = Sheets(S1).Cells(i, "F")
Cells(sat, "K") = Sheets(S1).Cells(i, "I")
Cells(sat, "L") = Sheets(S1).Cells(i, "H")
sat = sat + 1
Else: End If
Next i
End Sub
 
ZorBey_' Alıntı:
Denermisiniz.
Kod: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$B$2" <> Empty Then CommandButton1_Click
End Sub
Private Sub CommandButton1_Click()
S1 = "THP"
Range("A14:G65536").ClearContents
sat = 14
For i = 2 To Sheets(S1).[A65536].End(3).Row
If Range("B2") = Sheets(S1).Cells(i, "A") Then
'Cells(sat, "A") = sat - 11
sat = Range("A65536").End(xlUp).Row + 1
Cells(sat, "A") = Sheets(S1).Cells(i, "A")
Cells(sat, "B") = Sheets(S1).Cells(i, "B")
Cells(sat, "C") = Sheets(S1).Cells(i, "C")
Cells(sat, "D") = Sheets(S1).Cells(i, "D")
Cells(sat, "E") = Sheets(S1).Cells(i, "E")
Cells(sat, "F") = Sheets(S1).Cells(i, "F")
Cells(sat, "G") = Sheets(S1).Cells(i, "G")
sat = sat + 1
Else: End If
Next i
CommandButton2_Click
End Sub
Private Sub CommandButton2_Click()
S1 = "KSOZI"
Range("J14:L65536").ClearContents
sat = 14
For i = 2 To Sheets(S1).[A65536].End(3).Row
If Range("B2") = Sheets(S1).Cells(i, "A") Then
'Cells(sat, "A") = sat - 11
sat = Range("J65536").End(xlUp).Row + 1
Cells(sat, "J") = Sheets(S1).Cells(i, "F")
Cells(sat, "K") = Sheets(S1).Cells(i, "I")
Cells(sat, "L") = Sheets(S1).Cells(i, "H")
sat = sat + 1
Else: End If
Next i
End Sub
Genişletmek için tıkla ...

tam istediğim gibi bir makro oldu, ufak detayla yapamamışım. teşekür ederim.
 
Kolay gelsin iyi çalışmalar.
 
birinci makro kodunuzun altına call ikinci makronuzun adını yazarakta calıstırabilirsiniz ek bilgi :)
 
Aşağıdaki iki macro'yu aynı sayfada çalıştıramadım.
Yardımcı olursanız sevinirim...
Teşekkürler.... Ragıp CİVELEK

1. Macro

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [E3:E65536]) Is Nothing Then Cells(Target.Row, "A") = Format(Now, "d mmm yyyy dddd")
If Not Intersect(Target, [F3:F65536]) Is Nothing Then Cells(Target.Row, "A") = Format(Now, "d mmm yyyy dddd")
If Not Intersect(Target, [G3:G65536]) Is Nothing Then Cells(Target.Row, "A") = Format(Now, "d mmm yyyy dddd")
If Not Intersect(Target, [E3:E65536]) Is Nothing Then Cells(Target.Row, "B") = Format(Now, "h:mm")
If Not Intersect(Target, [F3:F65536]) Is Nothing Then Cells(Target.Row, "B") = Format(Now, "h:mm")
If Not Intersect(Target, [G3:G65536]) Is Nothing Then Cells(Target.Row, "B") = Format(Now, "h:mm")
End Sub

2. Macro


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Locked = True Then
şifre = Application.InputBox("Şifreyi giriniz")
If şifre = "123" Then
ActiveSheet.Unprotect "şifre"
Else
Cancel = True
End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target.Formula <> "" Then
ActiveSheet.Unprotect "şifre"
Target.Locked = True
ActiveSheet.Protect "şifre"
Else
ActiveSheet.Unprotect "şifre"
Target.Locked = False
ActiveSheet.Protect "şifre"
End If
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst