• DİKKAT

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

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

B

bedirster

Katılım
18 Ocak 2020
Mesajlar
62
Excel Vers. ve Dili
Office 2019 TR
64 Bit
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

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
 
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

  • 1678974660936.png
    1678974660936.png
    52.4 KB · Görüntüleme: 7
Merhaba,

konu günceldir. yok mu? yardımcı olabilecek bir arkadaşımız?
 
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
 
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
 
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
 
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

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.
Geri
Üst