farklı satırlara farklı hücrelerde aynı makroyu uygulama

B

bedirster

Altın Üye
Katılım
18 Ocak 2020
Mesajlar
62
Excel Vers. ve Dili
Office 2019 TR
64 Bit
Altın Üyelik Bitiş Tarihi
16-03-2026
Merhaba,
Aşağıdaki kod dağılımını farklı satır ve hücrelere de uygulamak istiyorum çalışan kod aşağıdaki gibi

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E27]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
[D28:G40,J28:J40].ClearContents
sut = WorksheetFunction.Match(Target, Sheets("veri").[B1:G1], 0) + 1
son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
a = 28
For i = 2 To son
Cells(a, "D") = Sheets("veri").Cells(i, sut)
Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
a = a + 1
Next
[D28].Select
son:
Application.ScreenUpdating = True
End Sub


ben aynı kodları aynı sayfa içerisinde aşağıdaki gibi uygulamak istiyorum ama maalesef çalışmadı

Private Sub Worksheet_Change1(ByVal Target As Range)
If Intersect(Target, [E70]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
[D71:G83,J71:J83].ClearContents
sut = WorksheetFunction.Match(Target, Sheets("veri").[J1:O1], 0) + 1
son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
a = 71
For i = 2 To son
Cells(a, "D") = Sheets("veri").Cells(i, sut)
Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
a = a + 1
Next
[D71].Select
son:
Application.ScreenUpdating = True
End Sub

yardımcı olursanız çok sevinirim.

teşekkürler


yardımcı olabilirmisiniz.

örnek dosya ektedir.
 

Ekli dosyalar

Y

yanginci34

Altın Üye
Katılım
6 Temmuz 2010
Mesajlar
1,659
Excel Vers. ve Dili
excel2016
Altın Üyelik Bitiş Tarihi
12-10-2026
Kodu bu şekilde denermisiniz
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E70,E27]) Is Nothing Then Exit Sub
If Target = Range("e:70") Then
    Application.ScreenUpdating = False
    [D71:G83,J71:J83].ClearContents
    sut = WorksheetFunction.Match(Target, Sheets("veri").[J1:O1], 0) + 1
    son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
    a = 71
    For i = 2 To son
        Cells(a, "D") = Sheets("veri").Cells(i, sut)
        Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
        a = a + 1
    Next
    [D71].Select
son:
    Application.ScreenUpdating = True
    ElseIf Target = Range("e:27") Then
    Application.ScreenUpdating = False
[D28:G40,J28:J40].ClearContents
sut = WorksheetFunction.Match(Target, Sheets("veri").[B1:G1], 0) + 1
son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
a = 28
For i = 2 To son
Cells(a, "D") = Sheets("veri").Cells(i, sut)
Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
a = a + 1
Next
[D28].Select
son:
Application.ScreenUpdating = True
End If
End Sub
 
B

bedirster

Altın Üye
Katılım
18 Ocak 2020
Mesajlar
62
Excel Vers. ve Dili
Office 2019 TR
64 Bit
Altın Üyelik Bitiş Tarihi
16-03-2026
yanginci34' Alıntı:
Kodu bu şekilde denermisiniz
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E70,E27]) Is Nothing Then Exit Sub
If Target = Range("e:70") Then
    Application.ScreenUpdating = False
    [D71:G83,J71:J83].ClearContents
    sut = WorksheetFunction.Match(Target, Sheets("veri").[J1:O1], 0) + 1
    son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
    a = 71
    For i = 2 To son
        Cells(a, "D") = Sheets("veri").Cells(i, sut)
        Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
        a = a + 1
    Next
    [D71].Select
son:
    Application.ScreenUpdating = True
    ElseIf Target = Range("e:27") Then
    Application.ScreenUpdating = False
[D28:G40,J28:J40].ClearContents
sut = WorksheetFunction.Match(Target, Sheets("veri").[B1:G1], 0) + 1
son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
a = 28
For i = 2 To son
Cells(a, "D") = Sheets("veri").Cells(i, sut)
Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
a = a + 1
Next
[D28].Select
son:
Application.ScreenUpdating = True
End If
End Sub
Genişletmek için tıkla ...

Resimdeki hatayı veriyor
 

Ekli dosyalar

B

bedirster

Altın Üye
Katılım
18 Ocak 2020
Mesajlar
62
Excel Vers. ve Dili
Office 2019 TR
64 Bit
Altın Üyelik Bitiş Tarihi
16-03-2026
Merhaba,

konu günceldir. yok mu? yardımcı olabilecek bir arkadaşımız?
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, [E27,E70]) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Range("D" & Target.Row + 1 & ":G" & Target.Row + 13).ClearContents
    Range("J" & Target.Row + 1 & ":J" & Target.Row + 13).ClearContents
    sut = WorksheetFunction.Match(Target, Sheets("veri").[B1:G1], 0) + 1
    Son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
    a = Target.Row + 1
    For i = 2 To Son
        Cells(a, "D") = Sheets("veri").Cells(i, sut)
        Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
        a = a + 1
    Next
    Range("D" & Target.Row + 1).Select
Son:
    Application.ScreenUpdating = True
End Sub
 
B

bedirster

Altın Üye
Katılım
18 Ocak 2020
Mesajlar
62
Excel Vers. ve Dili
Office 2019 TR
64 Bit
Altın Üyelik Bitiş Tarihi
16-03-2026
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, [E27,E70]) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Range("D" & Target.Row + 1 & ":G" & Target.Row + 13).ClearContents
    Range("J" & Target.Row + 1 & ":J" & Target.Row + 13).ClearContents
    sut = WorksheetFunction.Match(Target, Sheets("veri").[B1:G1], 0) + 1
    Son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
    a = Target.Row + 1
    For i = 2 To Son
        Cells(a, "D") = Sheets("veri").Cells(i, sut)
        Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
        a = a + 1
    Next
    Range("D" & Target.Row + 1).Select
Son:
    Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Merhaba,

yardımınız için teşekkür ederim. verdiğiniz kod çalışıyor ancak E70 teki tablo
sut = WorksheetFunction.Match(Target, Sheets("veri").[J1:O1], 0) + 1
veri olarak hücrelerini kullanması gerekiyor. bunun içinde yardımcı olabilir misiniz?

teşekkürler
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, [E27,E70]) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Range("D" & Target.Row + 1 & ":G" & Target.Row + 13).ClearContents
    Range("J" & Target.Row + 1 & ":J" & Target.Row + 13).ClearContents
    adres = IIf(Target.Row = 27, "B1:G1", "J1:O1")
    sut = WorksheetFunction.Match(Target, Sheets("veri").Range(adres), 0) + 1
    Son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
    a = Target.Row + 1
    For i = 2 To Son
        Cells(a, "D") = Sheets("veri").Cells(i, sut)
        Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
        a = a + 1
    Next
    Range("D" & Target.Row + 1).Select
Son:
    Application.ScreenUpdating = True
End Sub
 
B

bedirster

Altın Üye
Katılım
18 Ocak 2020
Mesajlar
62
Excel Vers. ve Dili
Office 2019 TR
64 Bit
Altın Üyelik Bitiş Tarihi
16-03-2026
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, [E27,E70]) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Range("D" & Target.Row + 1 & ":G" & Target.Row + 13).ClearContents
    Range("J" & Target.Row + 1 & ":J" & Target.Row + 13).ClearContents
    adres = IIf(Target.Row = 27, "B1:G1", "J1:O1")
    sut = WorksheetFunction.Match(Target, Sheets("veri").Range(adres), 0) + 1
    Son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
    a = Target.Row + 1
    For i = 2 To Son
        Cells(a, "D") = Sheets("veri").Cells(i, sut)
        Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
        a = a + 1
    Next
    Range("D" & Target.Row + 1).Select
Son:
    Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
Korhan Bey Merhaba,

Benmi yanlış bir şey yapıyorum, bilmiyorum ama yine Bve G hücrelerinin verileri geliyor. dosyayı verdiğiniz kodlar la tekrar ekliyorum.

teşekkürler
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,367
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Aşağıdaki gibi deneyiniz.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Son
    If Intersect(Target, [E27,E70]) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Range("D" & Target.Row + 1 & ":G" & Target.Row + 13).ClearContents
    Range("J" & Target.Row + 1 & ":J" & Target.Row + 13).ClearContents
    adres = IIf(Target.Row = 27, "B1:G1", "J1:O1")
    sut = Sheets("veri").Range(adres).Find(Target).Column
    Son = Sheets("veri").Cells(Rows.Count, sut).End(3).Row
    a = Target.Row + 1
    For i = 2 To Son
        Cells(a, "D") = Sheets("veri").Cells(i, sut)
        Cells(a, "I") = Sheets("veri").Cells(i, sut + 1)
        a = a + 1
    Next
    Range("D" & Target.Row + 1).Select
Son:
    Application.ScreenUpdating = True
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst