makroyu başka makroya ekleme

[sirkülasyon]

Option Explicit
Dim Eski_Veri As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H4")) Is Nothing Then Exit Sub
Dim Hücre As Range, Açıklama As String, WF As WorksheetFunction

Set WF = WorksheetFunction
Set Hücre = Target

On Error GoTo Son

Application.DisplayCommentIndicator = xlCommentIndicatorOnly

With Hücre
If .Value = "" Then GoTo Son
If .Value = Eski_Veri Then GoTo Son

If Eski_Veri = Empty Then
Açıklama = "Boş Hücre !" & WF.Rept(" ", 35 - Len("Boş Hücre !"))
Else
Açıklama = Eski_Veri & WF.Rept(" ", 35 - Len(Eski_Veri))
End If

If Not .Comment Is Nothing Then
.Comment.Text Text:=.Comment.Text & Chr(10) & Açıklama & Now
With .Comment.Shape
.Left = .Left
.Top = .Top
.Width = 250
.Height = .Height + 12.5
End With
Else
.AddComment
.Comment.Text Text:=.Comment.Text & Açıklama & Now
With .Comment.Shape
.Left = .Left
.Top = .Top
.Width = 250
.Height = 12.5
End With
End If

.Comment.Visible = True
End With
Son:
Set WF = Nothing
Set Hücre = Nothing
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("H4")) Is Nothing Then Exit Sub
Eski_Veri = Target.Value
End Sub



yukarıda yer alan makroya aşağıda bulunan makroyu birbirine nasıl bağlayabilirim.


Option Explicit
Dim İLK_VERİ As Variant

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [S17:S62,V17:V62]) Is Nothing Then Exit Sub
If Target = "" Then
İLK_VERİ = Empty
Exit Sub
End If
If IsNumeric(Target) Then
Application.EnableEvents = False
Target = İLK_VERİ + Target
Application.EnableEvents = True
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
İLK_VERİ = Target
End Sub

 

[Muzaffer Ali]

İkinci Prosedurun başlığını aşağıdaki gibi yapın

Public Sub Worksheet_Change(ByVal Target As Range)

Birinci prosedure aşağıdaki kodu ekleyin

dim sayfaadi as string 
sayfaadi="İkinciProsedurunBulunduğuSayfaAdı"
Worksheet(sayfaadı).Worksheet_Change target

 

[sirkülasyon]

Sayın Dalgalıkur;
İnancın olsun beceremedim. Himmet et birleştirilmiş şeklini ekleyebilir misin rica etsem?

 

[Muzaffer Ali]

yukarıdaki kodların hepsi aynı sayfada mı

eğer aynı sayfadaysa

Option Explicit
 Dim Eski_Veri As Variant
 Dim İLK_VERİ As Variant
 Private Sub Worksheet_Change(ByVal Target As Range)
 If Intersect(Target, Range("H4")) Is Nothing Then Exit Sub
 Dim Hücre As Range, Açıklama As String, WF As WorksheetFunction

 Set WF = WorksheetFunction
 Set Hücre = Target

 On Error GoTo Son

 Application.DisplayCommentIndicator = xlCommentIndicatorOnly

 With Hücre
 If .Value = "" Then GoTo Son
 If .Value = Eski_Veri Then GoTo Son

 If Eski_Veri = Empty Then
 Açıklama = "Boş Hücre !" & WF.Rept(" ", 35 - Len("Boş Hücre !"))
 Else
 Açıklama = Eski_Veri & WF.Rept(" ", 35 - Len(Eski_Veri))
 End If

 If Not .Comment Is Nothing Then
 .Comment.Text Text:=.Comment.Text & Chr(10) & Açıklama & Now
 With .Comment.Shape
 .Left = .Left
 .Top = .Top
 .Width = 250
 .Height = .Height + 12.5
 End With
 Else
 .AddComment
 .Comment.Text Text:=.Comment.Text & Açıklama & Now
 With .Comment.Shape
 .Left = .Left
 .Top = .Top
 .Width = 250
 .Height = 12.5
 End With
 End If

 .Comment.Visible = True
 End With
 Son:
 Set WF = Nothing
 Set Hücre = Nothing
 End Sub
 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If Intersect(Target, Range("H4")) Is Nothing Then Exit Sub
 Eski_Veri = Target.Value




 If Intersect(Target, [S17:S62,V17:V62]) Is Nothing Then Exit Sub
 If Target = "" Then
 İLK_VERİ = Empty
 Exit Sub
 End If
 If IsNumeric(Target) Then
 Application.EnableEvents = False
 Target = İLK_VERİ + Target
 Application.EnableEvents = True
 End If
 End Sub

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 İLK_VERİ = Target
 End Sub

eğer yinede çalışmazsa yada kodlar farklı sayfalardaysa dosyanı buraya ekle yapıp göndereyim

 

[sirkülasyon]

Sayın Dalgalıkur Abim

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
İLK_VERİ = Target
End Sub

yazan kod hata veriyor.

 

[Muzaffer Ali]

Biliyorum bu sorunun cevabını versem başka bişr sorun çıkacak bu sefer onu soracaksınız. Eğer dosyanızı buraya eklemezseniz size yardımcı olamıyacağım. Eğer dosyanız özelse verilerinizi sildikten sonra ekleyin. Sadece sayfalar kalsın sayfa isimlerini bilmem gerekiyor çünkü.