makro ile getirilen veride güncelleme

muhsar

Altın Üye
Katılım
16 Mart 2019
Mesajlar
270
Excel Vers. ve Dili
2010 tütkçe
Altın Üyelik Bitiş Tarihi
21-03-2029
günaydın ,iyi pazarlar,

aktif isimli sayfamdan düşeyara formülü ile getirdiğim verileri aşağıdaki kodlar ile makro ile getirmeye başladım.fakat formül ile çalışır iken aktif isimli sayfada değişiklik olunca aynı anda veri çektiğim sayfada da veriler değişiyordu fakat makroda doğal olarak değişmiyor.aşağıdaki kodlara nasıl bir ilave ile formülde olduğu gibi değişiklikler yansıyabilir. veya ayrı bir makro çalıştırarak çektiğim verilerde değişiklik varsa güncelleme yaptırabilirim.
ilgilenen arkadaşa şimdiden teşekkür ediyorum.


Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
    Set ahl = Sheets("AKTİF")
    fsat = Target.Row: deg = Target.Value
    If WorksheetFunction.CountIf(ahl.[A:A], deg) > 0 Then
        ahlsat = WorksheetFunction.Match(deg, ahl.[A:A], 0)
        Cells(fsat, "B") = ahl.Cells(ahlsat, "P")
        Cells(fsat, "C") = ahl.Cells(ahlsat, "Q")
         Cells(fsat, "D") = ahl.Cells(ahlsat, "H")
          Cells(fsat, "E") = ahl.Cells(ahlsat, "T")
          Cells(fsat, "J") = ahl.Cells(ahlsat, "T")
        Cells(fsat, "K") = ahl.Cells(ahlsat, "U")
        Cells(fsat, "L") = ahl.Cells(ahlsat, "H")
        Cells(fsat, "H") = ahl.Cells(ahlsat, "A")
        Cells(fsat, "I") = ahl.Cells(ahlsat, "P") & " " & ahl.Cells(ahlsat, "Q")
      
    Else
     Range("B" & fsat & ",C" & fsat & ",D" & fsat & ",E" & fsat & ",J" & fsat & ",K" & fsat & ",L" & fsat & ",H" & fsat & ",I" & fsat).ClearContents
    End If
End Sub
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,784
Excel Vers. ve Dili
Microsoft 365 Tr-64
İlgili satırlarda gerekli düzeltmeyi yapın.

If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
Application.EnableEvents = False


Application.EnableEvents =True
End Sub
 

muhsar

Altın Üye
Katılım
16 Mart 2019
Mesajlar
270
Excel Vers. ve Dili
2010 tütkçe
Altın Üyelik Bitiş Tarihi
21-03-2029
İlgili satırlarda gerekli düzeltmeyi yapın.

If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
Application.EnableEvents = False


Application.EnableEvents =True
End Sub

Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
Application.EnableEvents = False
    Set ahl = Sheets("AKTİF")
    fsat = Target.Row: deg = Target.Value
    If WorksheetFunction.CountIf(ahl.[A:A], deg) > 0 Then
        ahlsat = WorksheetFunction.Match(deg, ahl.[A:A], 0)
        Cells(fsat, "B") = ahl.Cells(ahlsat, "P")
        Cells(fsat, "C") = ahl.Cells(ahlsat, "Q")
         Cells(fsat, "D") = ahl.Cells(ahlsat, "H")
          Cells(fsat, "E") = ahl.Cells(ahlsat, "T")
          Cells(fsat, "J") = ahl.Cells(ahlsat, "T")
        Cells(fsat, "K") = ahl.Cells(ahlsat, "U")
        Cells(fsat, "L") = ahl.Cells(ahlsat, "H")
        Cells(fsat, "H") = ahl.Cells(ahlsat, "A")
        Cells(fsat, "I") = ahl.Cells(ahlsat, "P") & " " & ahl.Cells(ahlsat, "Q")
     
    Else
     Range("B" & fsat & ",C" & fsat & ",D" & fsat & ",E" & fsat & ",J" & fsat & ",K" & fsat & ",L" & fsat & ",H" & fsat & ",I" & fsat).ClearContents
    End If
    Application.EnableEvents = True
End Sub

kodları verdiğiniz ile değiştirdim, ve ekledim fakat aktif isimli sayfada veri değiştiğinde herhangi bir değişiklik olmadı,benmi yanlış yaptım.rica etsem kontrol edebilirmisiniz. örneğin Cells(fsat, "B") = ahl.Cells(ahlsat, "P") ilgili satıra göre aktif isimli sayfamda P sütunundaki ismi değiştirdim,verileri çektiğim tablomda B sütununda herhangi bir değişiklik olmadı
a sütunundaki veriyi silip yeniden veri çektiğimde doğru veri geliyor fakat benim yapmak istediğim kendiliğinden değişmesi.
 
Son düzenleme:

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Kodları eklediğiniz sayfaya aşağıdaki kodları da ilave ederek deneyiniz.
Kod:
Private Sub Worksheet_Activate()

    Set ahl = Sheets("AKTİF")
    fsat = Target.Row: deg = Target.Value
    If WorksheetFunction.CountIf(ahl.[A:A], deg) > 0 Then
        ahlsat = WorksheetFunction.Match(deg, ahl.[A:A], 0)
        Cells(fsat, "B") = ahl.Cells(ahlsat, "P")
        Cells(fsat, "C") = ahl.Cells(ahlsat, "Q")
         Cells(fsat, "D") = ahl.Cells(ahlsat, "H")
          Cells(fsat, "E") = ahl.Cells(ahlsat, "T")
          Cells(fsat, "J") = ahl.Cells(ahlsat, "T")
        Cells(fsat, "K") = ahl.Cells(ahlsat, "U")
        Cells(fsat, "L") = ahl.Cells(ahlsat, "H")
        Cells(fsat, "H") = ahl.Cells(ahlsat, "A")
        Cells(fsat, "I") = ahl.Cells(ahlsat, "P") & " " & ahl.Cells(ahlsat, "Q")
     
    Else
     Range("B" & fsat & ",C" & fsat & ",D" & fsat & ",E" & fsat & ",J" & fsat & ",K" & fsat & ",L" & fsat & ",H" & fsat & ",I" & fsat).ClearContents
    End If

End Sub
 

muhsar

Altın Üye
Katılım
16 Mart 2019
Mesajlar
270
Excel Vers. ve Dili
2010 tütkçe
Altın Üyelik Bitiş Tarihi
21-03-2029
Kodları eklediğiniz sayfaya aşağıdaki kodları da ilave ederek deneyiniz.
Kod:
Private Sub Worksheet_Activate()

    Set ahl = Sheets("AKTİF")
    fsat = Target.Row: deg = Target.Value
    If WorksheetFunction.CountIf(ahl.[A:A], deg) > 0 Then
        ahlsat = WorksheetFunction.Match(deg, ahl.[A:A], 0)
        Cells(fsat, "B") = ahl.Cells(ahlsat, "P")
        Cells(fsat, "C") = ahl.Cells(ahlsat, "Q")
         Cells(fsat, "D") = ahl.Cells(ahlsat, "H")
          Cells(fsat, "E") = ahl.Cells(ahlsat, "T")
          Cells(fsat, "J") = ahl.Cells(ahlsat, "T")
        Cells(fsat, "K") = ahl.Cells(ahlsat, "U")
        Cells(fsat, "L") = ahl.Cells(ahlsat, "H")
        Cells(fsat, "H") = ahl.Cells(ahlsat, "A")
        Cells(fsat, "I") = ahl.Cells(ahlsat, "P") & " " & ahl.Cells(ahlsat, "Q")
    
    Else
     Range("B" & fsat & ",C" & fsat & ",D" & fsat & ",E" & fsat & ",J" & fsat & ",K" & fsat & ",L" & fsat & ",H" & fsat & ",I" & fsat).ClearContents
    End If

End Sub
Kod:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
    Set ahl = Sheets("AKTİF")
    fsat = Target.Row: deg = Target.Value
    If WorksheetFunction.CountIf(ahl.[A:A], deg) > 0 Then
        ahlsat = WorksheetFunction.Match(deg, ahl.[A:A], 0)
        Cells(fsat, "B") = ahl.Cells(ahlsat, "P")
        Cells(fsat, "C") = ahl.Cells(ahlsat, "Q")
         Cells(fsat, "D") = ahl.Cells(ahlsat, "H")
          Cells(fsat, "E") = ahl.Cells(ahlsat, "T")
          Cells(fsat, "J") = ahl.Cells(ahlsat, "T")
        Cells(fsat, "K") = ahl.Cells(ahlsat, "U")
        Cells(fsat, "L") = ahl.Cells(ahlsat, "H")
        Cells(fsat, "H") = ahl.Cells(ahlsat, "A")
        Cells(fsat, "I") = ahl.Cells(ahlsat, "P") & " " & ahl.Cells(ahlsat, "Q")
      
    Else
     Range("B" & fsat & ",C" & fsat & ",D" & fsat & ",E" & fsat & ",J" & fsat & ",K" & fsat & ",L" & fsat & ",H" & fsat & ",I" & fsat).ClearContents
    End If
End Sub

Private Sub Worksheet_Activate()

    Set ahl = Sheets("AKTİF")
    fsat = Target.Row: deg = Target.Value
    If WorksheetFunction.CountIf(ahl.[A:A], deg) > 0 Then
        ahlsat = WorksheetFunction.Match(deg, ahl.[A:A], 0)
        Cells(fsat, "B") = ahl.Cells(ahlsat, "P")
        Cells(fsat, "C") = ahl.Cells(ahlsat, "Q")
         Cells(fsat, "D") = ahl.Cells(ahlsat, "H")
          Cells(fsat, "E") = ahl.Cells(ahlsat, "T")
          Cells(fsat, "J") = ahl.Cells(ahlsat, "T")
        Cells(fsat, "K") = ahl.Cells(ahlsat, "U")
        Cells(fsat, "L") = ahl.Cells(ahlsat, "H")
        Cells(fsat, "H") = ahl.Cells(ahlsat, "A")
        Cells(fsat, "I") = ahl.Cells(ahlsat, "P") & " " & ahl.Cells(ahlsat, "Q")
    
    Else
     Range("B" & fsat & ",C" & fsat & ",D" & fsat & ",E" & fsat & ",J" & fsat & ",K" & fsat & ",L" & fsat & ",H" & fsat & ",I" & fsat).ClearContents
    End If

End Sub
ömer hocam önceki kodlarımın altına bunları eklediğimde böyle bir görüntü oldu,yanlışmı anladım acaba?
hocam aktif sayfasından hücreyi değiştirdiğimde düşeyara formülünde olduğu gibi veri çekilerek oluşan tablo da değişirmi,yoksa bunu ayrı bir makro ilemi çözmeliyim
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Ben konuyu yanlış anlamışım sanırım.
Basit bir örnek ekler misiniz. Örnek üzerinden ilerleyelim.
 

muhsar

Altın Üye
Katılım
16 Mart 2019
Mesajlar
270
Excel Vers. ve Dili
2010 tütkçe
Altın Üyelik Bitiş Tarihi
21-03-2029
Ben konuyu yanlış anlamışım sanırım.
Basit bir örnek ekler misiniz. Örnek üzerinden ilerleyelim.
ömer hocam hasta bilgileri olduğu için verileri minimuma indirdim;altta ekip 1 isimli sahife ekip 15 e kadar devam ediyor,sadece ekip 1 bıraktım diğerlerini sildim.aktif sayfasında 10 adet veri bıraktım.ekip 1 isimli sayfada dosya numarasını yazıp gerekli verileri çekiyorum fakat aktif isimli sayfada örneğin ekip 1 yazan h sütunun ekip 2 çe çevirdiğimde ekip 1 isimli sahifedende otomatik değişmesi mümkünmü,kendi ürettiğim çözümüde ekledim.
 

Ekli dosyalar

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Eski verdiğim kodları silip aynı sayfaya;
Kod:
Private Sub Worksheet_Activate()
    Call Module3.veri_al
End Sub

Aşağıdaki kodlarıda Module3 e ekleyiniz.
Kod:
Sub veri_al()

    Dim S1 As Worksheet, S2 As Worksheet, i As Long, c As Range
    
    Set S1 = Sheets("ekip 1")
    Set S2 = Sheets("AKTİF")
    
    Application.ScreenUpdating = False
    
    For i = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
        If S1.Cells(i, "A") <> "" Then
            Set c = S2.[A:A].Find(S1.Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                S1.Cells(i, "B") = S2.Cells(c.Row, "P")
                S1.Cells(i, "C") = S2.Cells(c.Row, "Q")
                S1.Cells(i, "D") = S2.Cells(c.Row, "H")
                S1.Cells(i, "E") = S2.Cells(c.Row, "T")
                S1.Cells(i, "J") = S2.Cells(c.Row, "T")
                S1.Cells(i, "K") = S2.Cells(c.Row, "U")
                S1.Cells(i, "L") = S2.Cells(c.Row, "H")
                S1.Cells(i, "H") = S2.Cells(c.Row, "A")
                S1.Cells(i, "I") = S2.Cells(c.Row, "P") & " " & S2.Cells(c.Row, "Q")
            Else
                S1.Range("B" & i & ",C" & i & ",D" & i & ",E" & i & ",J" & i & ",K" & i & ",L" & i & ",H" & i & ",I" & i).ClearContents
            End If
        End If
    Next i
    
End Sub
Not: Detaylı deneme yapmadım. Hata varsa nedenini detaylı açıklayınız.
 

muhsar

Altın Üye
Katılım
16 Mart 2019
Mesajlar
270
Excel Vers. ve Dili
2010 tütkçe
Altın Üyelik Bitiş Tarihi
21-03-2029
Eski verdiğim kodları silip aynı sayfaya;
Kod:
Private Sub Worksheet_Activate()
    Call Module3.veri_al
End Sub

Aşağıdaki kodlarıda Module3 e ekleyiniz.
Kod:
Sub veri_al()

    Dim S1 As Worksheet, S2 As Worksheet, i As Long, c As Range
   
    Set S1 = Sheets("ekip 1")
    Set S2 = Sheets("AKTİF")
   
    Application.ScreenUpdating = False
   
    For i = 2 To S1.Cells(Rows.Count, "A").End(xlUp).Row
        If S1.Cells(i, "A") <> "" Then
            Set c = S2.[A:A].Find(S1.Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                S1.Cells(i, "B") = S2.Cells(c.Row, "P")
                S1.Cells(i, "C") = S2.Cells(c.Row, "Q")
                S1.Cells(i, "D") = S2.Cells(c.Row, "H")
                S1.Cells(i, "E") = S2.Cells(c.Row, "T")
                S1.Cells(i, "J") = S2.Cells(c.Row, "T")
                S1.Cells(i, "K") = S2.Cells(c.Row, "U")
                S1.Cells(i, "L") = S2.Cells(c.Row, "H")
                S1.Cells(i, "H") = S2.Cells(c.Row, "A")
                S1.Cells(i, "I") = S2.Cells(c.Row, "P") & " " & S2.Cells(c.Row, "Q")
            Else
                S1.Range("B" & i & ",C" & i & ",D" & i & ",E" & i & ",J" & i & ",K" & i & ",L" & i & ",H" & i & ",I" & i).ClearContents
            End If
        End If
    Next i
   
End Sub
Not: Detaylı deneme yapmadım. Hata varsa nedenini detaylı açıklayınız.
ömer hocam ;çok teşekkür ederim ellerinize sağlık,hata vermeden güncelledi
 

muhsar

Altın Üye
Katılım
16 Mart 2019
Mesajlar
270
Excel Vers. ve Dili
2010 tütkçe
Altın Üyelik Bitiş Tarihi
21-03-2029
ömer hocam ;çok teşekkür ederim ellerinize sağlık,hata vermeden güncelledi
ömer hocam modül kodlarına sadece ekip 1 işlem yapıyor,oysa ben dosyayı küçültmek için diğer ekipleri silmiştim,aynı şekilde modülleri çoğaltarak ve kodu ekip 2 ekip 3 .. şeklinde diğer sayfalarda güncelleyerek devam edip sorunu çözdüm,bunun kısa yolu varmı acaba?
Set S1 = Sheets("ekip 1")
Set S2 = Sheets("AKTİF")
ilk satıra ekip 2 3 4 gibi ekipleri yazdığımda olmadı

mevcut şekilde işimi gördü ama merak ettiğim için sordum.çok teşekkür ediyorum
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Module3 deki kodları aşağıdakilerle değiştirin.
Kod:
Sub veri_al()

    Dim S2 As Worksheet, i As Long, c As Range
    
    Set S2 = Sheets("AKTİF")
    
    Application.ScreenUpdating = False
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A") <> "" Then
            Set c = S2.[A:A].Find(Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Cells(i, "B") = S2.Cells(c.Row, "P")
                Cells(i, "C") = S2.Cells(c.Row, "Q")
                Cells(i, "D") = S2.Cells(c.Row, "H")
                Cells(i, "E") = S2.Cells(c.Row, "T")
                Cells(i, "J") = S2.Cells(c.Row, "T")
                Cells(i, "K") = S2.Cells(c.Row, "U")
                Cells(i, "L") = S2.Cells(c.Row, "H")
                Cells(i, "H") = S2.Cells(c.Row, "A")
                Cells(i, "I") = S2.Cells(c.Row, "P") & " " & S2.Cells(c.Row, "Q")
            Else
                Range("B" & i & ",C" & i & ",D" & i & ",E" & i & ",J" & i & ",K" & i & ",L" & i & ",H" & i & ",I" & i).ClearContents
            End If
        End If
    Next i
    
End Sub

Daha sonra tüm ekip sayfalarındaki mevcut kodların tümünü silin ve aşağıdaki kodları "Bu ÇalışmaKitabı" (ThisWorkBook) kod saydasına kopyalayınız.
Kod:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    If ActiveSheet.Name Like "*ekip*" Then
        If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
        Set ahl = Sheets("AKTİF")
        fsat = Target.Row: deg = Target.Value
        If WorksheetFunction.CountIf(ahl.[A:A], deg) > 0 Then
            ahlsat = WorksheetFunction.Match(deg, ahl.[A:A], 0)
            Cells(fsat, "B") = ahl.Cells(ahlsat, "P")
            Cells(fsat, "C") = ahl.Cells(ahlsat, "Q")
             Cells(fsat, "D") = ahl.Cells(ahlsat, "H")
              Cells(fsat, "E") = ahl.Cells(ahlsat, "T")
              Cells(fsat, "J") = ahl.Cells(ahlsat, "T")
            Cells(fsat, "K") = ahl.Cells(ahlsat, "U")
            Cells(fsat, "L") = ahl.Cells(ahlsat, "H")
            Cells(fsat, "H") = ahl.Cells(ahlsat, "A")
            Cells(fsat, "I") = ahl.Cells(ahlsat, "P") & " " & ahl.Cells(ahlsat, "Q")
          
        Else
         Range("B" & fsat & ",C" & fsat & ",D" & fsat & ",E" & fsat & ",J" & fsat & ",K" & fsat & ",L" & fsat & ",H" & fsat & ",I" & fsat).ClearContents
        End If
    End If
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If ActiveSheet.Name Like "*ekip*" Then
        Call Module3.veri_al
    End If
End Sub
 

muhsar

Altın Üye
Katılım
16 Mart 2019
Mesajlar
270
Excel Vers. ve Dili
2010 tütkçe
Altın Üyelik Bitiş Tarihi
21-03-2029
Module3 deki kodları aşağıdakilerle değiştirin.
Kod:
Sub veri_al()

    Dim S2 As Worksheet, i As Long, c As Range
   
    Set S2 = Sheets("AKTİF")
   
    Application.ScreenUpdating = False
   
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(i, "A") <> "" Then
            Set c = S2.[A:A].Find(Cells(i, "A"), , xlValues, xlWhole)
            If Not c Is Nothing Then
                Cells(i, "B") = S2.Cells(c.Row, "P")
                Cells(i, "C") = S2.Cells(c.Row, "Q")
                Cells(i, "D") = S2.Cells(c.Row, "H")
                Cells(i, "E") = S2.Cells(c.Row, "T")
                Cells(i, "J") = S2.Cells(c.Row, "T")
                Cells(i, "K") = S2.Cells(c.Row, "U")
                Cells(i, "L") = S2.Cells(c.Row, "H")
                Cells(i, "H") = S2.Cells(c.Row, "A")
                Cells(i, "I") = S2.Cells(c.Row, "P") & " " & S2.Cells(c.Row, "Q")
            Else
                Range("B" & i & ",C" & i & ",D" & i & ",E" & i & ",J" & i & ",K" & i & ",L" & i & ",H" & i & ",I" & i).ClearContents
            End If
        End If
    Next i
   
End Sub

Daha sonra tüm ekip sayfalarındaki mevcut kodların tümünü silin ve aşağıdaki kodları "Bu ÇalışmaKitabı" (ThisWorkBook) kod saydasına kopyalayınız.
Kod:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    If ActiveSheet.Name Like "*ekip*" Then
        If Target.Column <> 1 Or Target.Row < 2 Then Exit Sub
        Set ahl = Sheets("AKTİF")
        fsat = Target.Row: deg = Target.Value
        If WorksheetFunction.CountIf(ahl.[A:A], deg) > 0 Then
            ahlsat = WorksheetFunction.Match(deg, ahl.[A:A], 0)
            Cells(fsat, "B") = ahl.Cells(ahlsat, "P")
            Cells(fsat, "C") = ahl.Cells(ahlsat, "Q")
             Cells(fsat, "D") = ahl.Cells(ahlsat, "H")
              Cells(fsat, "E") = ahl.Cells(ahlsat, "T")
              Cells(fsat, "J") = ahl.Cells(ahlsat, "T")
            Cells(fsat, "K") = ahl.Cells(ahlsat, "U")
            Cells(fsat, "L") = ahl.Cells(ahlsat, "H")
            Cells(fsat, "H") = ahl.Cells(ahlsat, "A")
            Cells(fsat, "I") = ahl.Cells(ahlsat, "P") & " " & ahl.Cells(ahlsat, "Q")
         
        Else
         Range("B" & fsat & ",C" & fsat & ",D" & fsat & ",E" & fsat & ",J" & fsat & ",K" & fsat & ",L" & fsat & ",H" & fsat & ",I" & fsat).ClearContents
        End If
    End If
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If ActiveSheet.Name Like "*ekip*" Then
        Call Module3.veri_al
    End If
End Sub
çok teşekkür ederim,elinize sağlık
 
Üst