İki Tablo arasında senkronize ama koşullu :)

erkanersoy · 1 Ekim 2010

Saygı değer ustalar 10 gündür bir şey yapmaya çalışıyorum. Amaç her ay değişken olan bir sayfadaki veriyle, içinde formülleri barındıran başka bir veri sayfasını senkronize edip, yeni eklenen satırları eklendikleri yerde bulunan verinin üzerine yazmadan (yeni satır ekleyerek) kopyalamak. Fakat bir türlü beceremedim. Konuyla ilgili detayları ekteki dosyalardan pum.xls nin içinde yazdım. pum.xls nin içinde ki ORNEK sayfasında da örnekli bir anlatım var. yardımlarınızı rica ediyorum.
Teşekkürler

Korhan Ayhan · 2 Ekim 2010

Selamlar,

İki kitabıda aynı klasör içine alın. Daha sonra "Deneme" isimli kitabınızda boş bir modüle aşağıdaki kodu uygulayın. Daha sonra kodu bir butona bağlayıp çalıştırın.

Kod:

Option Explicit
 
Sub VERİLERİ_AKTAR()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, BUL As Range, EN_YAKIN As Long
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sistemden İndirilen Tüketimler")
    Set K2 = Workbooks.Open(K1.Path & "\" & "pum.xls", False, False)
    Set S2 = K2.Sheets("Yeni Kayıt")
    
    K1.Activate
    
    For X = 9 To S2.Range("A65536").End(3).Row
        If S2.Cells(X, 1) <> "" Then
            Set BUL = S1.Range("B:B").Find(S2.Cells(X, 1), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                S1.Range("B" & BUL.Row & ":G" & BUL.Row).Value = S2.Range("A" & X & ":F" & X).Value
                GoTo Devam
            End If
            
            EN_YAKIN = WorksheetFunction.VLookup(S2.Cells(X, 1), S1.Range("B:B"), 1, 1)
            If EN_YAKIN > 0 Then
                Set BUL = S1.Range("B:B").Find(EN_YAKIN, LookAt:=xlWhole)
                If Not BUL Is Nothing Then
                    BUL.Offset(1, 0).EntireRow.Insert
                    S1.Range("O" & BUL.Row & ":Y" & BUL.Row + 1).FillDown
                    S1.Range("B" & BUL.Row + 1 & ":G" & BUL.Row + 1).Value = S2.Range("A" & X & ":F" & X).Value
                    GoTo Devam
                End If
            End If
        End If
Devam:
    Next
    
    K2.Close
    S1.Activate
    
    Set BUL = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

erkanersoy · 4 Ekim 2010

Korhan Bey elinize emeğinize sağlık. Bu sizden aldığım ilk destek değil. Öyle gözüküyor ki sonda olmayacak.

Tekrar tekrar teşekkür ederim.

erkanersoy · 6 Ekim 2010

Korhan Ayhan' Alıntı:

Selamlar,

İki kitabıda aynı klasör içine alın. Daha sonra "Deneme" isimli kitabınızda boş bir modüle aşağıdaki kodu uygulayın. Daha sonra kodu bir butona bağlayıp çalıştırın.

Kod:

Option Explicit
 
Sub VERİLERİ_AKTAR()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, BUL As Range, EN_YAKIN As Long
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sistemden İndirilen Tüketimler")
    Set K2 = Workbooks.Open(K1.Path & "\" & "pum.xls", False, False)
    Set S2 = K2.Sheets("Yeni Kayıt")
    
    K1.Activate
    
    For X = 9 To S2.Range("A65536").End(3).Row
        If S2.Cells(X, 1) <> "" Then
            Set BUL = S1.Range("B:B").Find(S2.Cells(X, 1), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                S1.Range("B" & BUL.Row & ":G" & BUL.Row).Value = S2.Range("A" & X & ":F" & X).Value
                GoTo Devam
            End If
            
            EN_YAKIN = WorksheetFunction.VLookup(S2.Cells(X, 1), S1.Range("B:B"), 1, 1)
            If EN_YAKIN > 0 Then
                Set BUL = S1.Range("B:B").Find(EN_YAKIN, LookAt:=xlWhole)
                If Not BUL Is Nothing Then
                    BUL.Offset(1, 0).EntireRow.Insert
                    S1.Range("O" & BUL.Row & ":Y" & BUL.Row + 1).FillDown
                    S1.Range("B" & BUL.Row + 1 & ":G" & BUL.Row + 1).Value = S2.Range("A" & X & ":F" & X).Value
                    GoTo Devam
                End If
            End If
        End If
Devam:
    Next
    
    K2.Close
    S1.Activate
    
    Set BUL = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

Korhan Bey kolay gelsin. Kodla ilgili gözden kaçırdığım bir nokta olmuş. Anladığım kadarı ile değişikliğin başladığı ilk satırdan sonraki her satırda D,E,F,G sütunlarını güncelliyor, değişikliğin üztünde kalan aynı sütunlardaki sayıları güncellemedi. Bunu nasıl düzeltebilirim acaba. Teşekkürler.

Korhan Ayhan · 6 Ekim 2010

Selamlar,

Kod 9. satırdan itibaren tüm verileri kontrol ediyor. DEĞİŞİKLİĞİN ÜSTÜNDEKİ satırlardan kastınızı anlayamadım. Örnek dosyanız üzerinde açıklarmısınız.

erkanersoy · 7 Ekim 2010

Korhan Ayhan' Alıntı:
Selamlar,

Kod 9. satırdan itibaren tüm verileri kontrol ediyor. DEĞİŞİKLİĞİN ÜSTÜNDEKİ satırlardan kastınızı anlayamadım. Örnek dosyanız üzerinde açıklarmısınız.

Evet söylemek istediğimde oydu. Dokuzuncu satıra kadar olan D-E-F-G sütunlarındaki sayı değerlerini Pum.xls nin içinden alıp güncellemiyor. kopyalanmayan alanı deneme xls nin içinde kırmızı ile işaretledim. Teşekkürler..

Korhan Ayhan · 7 Ekim 2010

Selamlar,

Sanıyorum dosyanız üzerinde denemeler yaparken 9 değerini düzeltmeyi unutmuşum.

Kod içindeki "For X = 9" ifadesini aşağıdaki şekilde değiştirip deneyin.

Kod:

For X = 1

erkanersoy · 8 Ekim 2010

Korhan Ayhan' Alıntı:
Selamlar,

Sanıyorum dosyanız üzerinde denemeler yaparken 9 değerini düzeltmeyi unutmuşum.

Kod içindeki "For X = 9" ifadesini aşağıdaki şekilde değiştirip deneyin.

Kod:

For X = 1

Korhan Bey sorun ortadan kalkmıştır. Teşekkür ederim. Dikkat ettiyseniz, Yeni kayıt içindeki verileri Sistemden indirilen Tüketimler sayfasına getirirken, Daha önceden Sistemden İndirilen tüketimler de olupta, yeni kayıt sayfasında olmayan aboneler olduğu gibi kalıyor. yazdığınız kodlara ilave olarak kod işini bitirdikten sonra iki sayfayı karşılaştırıp yeni kayıt sayfasında olmayan fakat Sistemden indirilen tüketimler sayfasında daha önceden kalan abonelerin satırlarını sildirebilirmiyiz. Teşekkürler....

erkanersoy · 10 Ekim 2010

erkanersoy' Alıntı:
Korhan Bey sorun ortadan kalkmıştır. Teşekkür ederim. Dikkat ettiyseniz, Yeni kayıt içindeki verileri Sistemden indirilen Tüketimler sayfasına getirirken, Daha önceden Sistemden İndirilen tüketimler de olupta, yeni kayıt sayfasında olmayan aboneler olduğu gibi kalıyor. yazdığınız kodlara ilave olarak kod işini bitirdikten sonra iki sayfayı karşılaştırıp yeni kayıt sayfasında olmayan fakat Sistemden indirilen tüketimler sayfasında daha önceden kalan abonelerin satırlarını sildirebilirmiyiz. Teşekkürler....

Günceldir....

Korhan Ayhan · 10 Ekim 2010

Selamlar,

Aşağıdaki kodu denermisiniz.

Kod:

Option Explicit
 
Sub VERİLERİ_AKTAR()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, BUL As Range, EN_YAKIN As Long
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sistemden İndirilen Tüketimler")
    Set K2 = Workbooks.Open(K1.Path & "\" & "pum.xls", False, False)
    Set S2 = K2.Sheets("Yeni Kayıt")
    
    K1.Activate
    
    For X = 1 To S2.Range("A65536").End(3).Row
        If S2.Cells(X, 1) <> "" Then
            Set BUL = S1.Range("B:B").Find(S2.Cells(X, 1), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                S1.Range("B" & BUL.Row & ":G" & BUL.Row).Value = S2.Range("A" & X & ":F" & X).Value
                GoTo Devam
            End If
            
            EN_YAKIN = WorksheetFunction.VLookup(S2.Cells(X, 1), S1.Range("B:B"), 1, 1)
            If EN_YAKIN > 0 Then
                Set BUL = S1.Range("B:B").Find(EN_YAKIN, LookAt:=xlWhole)
                If Not BUL Is Nothing Then
                    BUL.Offset(1, 0).EntireRow.Insert
                    S1.Range("O" & BUL.Row & ":Y" & BUL.Row + 1).FillDown
                    S1.Range("B" & BUL.Row + 1 & ":G" & BUL.Row + 1).Value = S2.Range("A" & X & ":F" & X).Value
                    GoTo Devam
                End If
            End If
        End If
Devam:
    Next
    
    For X = S1.Range("B65536").End(3).Row To 4 Step -1
        If WorksheetFunction.CountIf(S2.Range("A:A"), S1.Cells(X, 2)) = 0 Then
            Rows(X).Delete
        End If
    Next
    
    K2.Close
    S1.Activate
    
    Set BUL = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

erkanersoy · 10 Ekim 2010

Korhan Ayhan' Alıntı:

Selamlar,

Aşağıdaki kodu denermisiniz.

Kod:

Option Explicit
 
Sub VERİLERİ_AKTAR()
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, BUL As Range, EN_YAKIN As Long
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sistemden İndirilen Tüketimler")
    Set K2 = Workbooks.Open(K1.Path & "\" & "pum.xls", False, False)
    Set S2 = K2.Sheets("Yeni Kayıt")
    
    K1.Activate
    
    For X = 1 To S2.Range("A65536").End(3).Row
        If S2.Cells(X, 1) <> "" Then
            Set BUL = S1.Range("B:B").Find(S2.Cells(X, 1), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
                S1.Range("B" & BUL.Row & ":G" & BUL.Row).Value = S2.Range("A" & X & ":F" & X).Value
                GoTo Devam
            End If
            
            EN_YAKIN = WorksheetFunction.VLookup(S2.Cells(X, 1), S1.Range("B:B"), 1, 1)
            If EN_YAKIN > 0 Then
                Set BUL = S1.Range("B:B").Find(EN_YAKIN, LookAt:=xlWhole)
                If Not BUL Is Nothing Then
                    BUL.Offset(1, 0).EntireRow.Insert
                    S1.Range("O" & BUL.Row & ":Y" & BUL.Row + 1).FillDown
                    S1.Range("B" & BUL.Row + 1 & ":G" & BUL.Row + 1).Value = S2.Range("A" & X & ":F" & X).Value
                    GoTo Devam
                End If
            End If
        End If
Devam:
    Next
    
    For X = S1.Range("B65536").End(3).Row To 4 Step -1
        If WorksheetFunction.CountIf(S2.Range("A:A"), S1.Cells(X, 2)) = 0 Then
            Rows(X).Delete
        End If
    Next
    
    K2.Close
    S1.Activate
    
    Set BUL = Nothing
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

Korhan Bey elinize sağlık çok iyi olmuş. Şimdi bir yedeğini alıp üzerinde değişiklikler yapıp bazı şeyleri anlamaya çalışacağım. Benim için çok faydalı oldu. Tekrar teşekkür

erkanersoy · 26 Aralık 2010

çoklu süzme hakkında

Korhan bey daha önce kodlarını yazdığınız dosyamla ilgili küçük bir ek yapmam gerekiyor. Bu ekle 7 ayrı tablo oluşturacağım. Bir tanesinde yardımcı olabilirseniz kodlarınızda değişiklik yaparak diğerlerini ben hazırlamak istiyorum. Konuyu ek'teki dosyanın içinde TEKİRDAĞ sayfasında detaylandırdım. fırsat bulup ta bakabilirseniz çok memnun olurum. İyi günler ve yardımlarınız için teşekkürler...

Korhan Ayhan · 26 Aralık 2010

Selamlar,

Aşağıdaki kodu denermisiniz. Kodlarda TOPLA.ÇARPIM fonksiyonunun makro hali kullanılmıştır. Size sadece sayfaları kopyalayıp isimlerini düzenlemek kalıyor. Yani "TEKİRDAĞ" isimli sayfayı kopyalayıp yeni sayfanın ismini "ÇORLU" yaptığınızda kod otomatik olarak yeni isme göre çalışacaktır.

Kod:

Option Explicit
 
Sub BİLGİLERİ_GÜNCELLE()
    Dim S1 As Worksheet, S2 As Worksheet, Son_Satır As Long
    Dim BUL As Range, ADRES As String, Satır As Long
 
    Set S1 = Sheets("Sistemden İndirilen Tüketimler")
    Set S2 = ActiveSheet
    Satır = 5
    Son_Satır = S1.Range("C65536").End(3).Row
 
    Application.ScreenUpdating = False
 
    S2.Range("A5:J65536").ClearContents
 
    Set BUL = S1.Range("X:X").Find(S2.Name, LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
        If WorksheetFunction.CountIf(S2.Range("A:A"), S1.Cells(BUL.Row, "Y")) = 0 Then
            S2.Cells(Satır, "A") = S1.Cells(BUL.Row, "Y")
            S2.Cells(Satır, "B") = Evaluate("=SUMPRODUCT(('" & S1.Name & "'!X4:X" & Son_Satır & "=""" & S2.Name & """)*('" & S1.Name & "'!Y4:Y" & Son_Satır & "=""" & S2.Cells(Satır, "A") & """)*('" & S1.Name & "'!I4:I" & Son_Satır & "=1),('" & S1.Name & "'!D4:D" & Son_Satır & "))")
            S2.Cells(Satır, "C") = Evaluate("=SUMPRODUCT(('" & S1.Name & "'!X4:X" & Son_Satır & "=""" & S2.Name & """)*('" & S1.Name & "'!Y4:Y" & Son_Satır & "=""" & S2.Cells(Satır, "A") & """)*('" & S1.Name & "'!I4:I" & Son_Satır & "=1),('" & S1.Name & "'!Q4:Q" & Son_Satır & "))")
            S2.Cells(Satır, "D") = Evaluate("=SUMPRODUCT(('" & S1.Name & "'!X4:X" & Son_Satır & "=""" & S2.Name & """)*('" & S1.Name & "'!Y4:Y" & Son_Satır & "=""" & S2.Cells(Satır, "A") & """)*('" & S1.Name & "'!I4:I" & Son_Satır & "=1),('" & S1.Name & "'!S4:S" & Son_Satır & "))")
            S2.Cells(Satır, "E") = Evaluate("=SUMPRODUCT(('" & S1.Name & "'!X4:X" & Son_Satır & "=""" & S2.Name & """)*('" & S1.Name & "'!Y4:Y" & Son_Satır & "=""" & S2.Cells(Satır, "A") & """)*('" & S1.Name & "'!I4:I" & Son_Satır & "=2),('" & S1.Name & "'!D4:D" & Son_Satır & "))")
            S2.Cells(Satır, "F") = Evaluate("=SUMPRODUCT(('" & S1.Name & "'!X4:X" & Son_Satır & "=""" & S2.Name & """)*('" & S1.Name & "'!Y4:Y" & Son_Satır & "=""" & S2.Cells(Satır, "A") & """)*('" & S1.Name & "'!I4:I" & Son_Satır & "=2),('" & S1.Name & "'!Q4:Q" & Son_Satır & "))")
            S2.Cells(Satır, "G") = Evaluate("=SUMPRODUCT(('" & S1.Name & "'!X4:X" & Son_Satır & "=""" & S2.Name & """)*('" & S1.Name & "'!Y4:Y" & Son_Satır & "=""" & S2.Cells(Satır, "A") & """)*('" & S1.Name & "'!I4:I" & Son_Satır & "=2),('" & S1.Name & "'!S4:S" & Son_Satır & "))")
            S2.Cells(Satır, "H") = S2.Cells(Satır, "B") + S2.Cells(Satır, "E")
            S2.Cells(Satır, "I") = S2.Cells(Satır, "C") + S2.Cells(Satır, "F")
            S2.Cells(Satır, "J") = S2.Cells(Satır, "D") + S2.Cells(Satır, "G")
            Satır = Satır + 1
        End If
 
    Set BUL = S1.Range("X:X").FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
 
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

erkanersoy · 28 Aralık 2010

ufak bir değişiklik

Korhan hocam yine uzmanlığınızı konuşturmuşsunuz. Elinize emeğinize sağlık tek kelime ile harika olmuş. Aynı kodları dosyayı yedekledikten sonra dosyadaki TARİFELER BAZINDA sayfasında da kodlarda değişiklik yaparak denedim. ama sonu hüsran oldu

. dosyayı sizin yazdığınız kodlar eklenmiş sağlam ve çalışır halde

tekrar ekliyorum. Fırsat bulabilirseniz TARİFELER BAZINDA sayfasına bir göz atabilir misiniz.

Korhan Ayhan · 29 Aralık 2010

Selamlar,

Aşağıdaki kodu denermisiniz.

Kod:

Option Explicit
 
Sub TARİFELER_BAZINDA_AYLIK_İCMAL()
    Dim S1 As Worksheet, S2 As Worksheet, Adres As String
    Dim Son_Satır As Long, X As Integer, Y As Byte
 
    Set S1 = Sheets("Sistemden İndirilen Tüketimler")
    Set S2 = Sheets("TARİFELER BAZINDA")
    Son_Satır = S1.Range("C65536").End(3).Row
 
    Application.ScreenUpdating = False
 
    S2.Range("A4:IV65536").Clear
 
    S1.Range("Y3:Y65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Range("IV1"), Unique:=True
    S1.Range("IV2:IV65536").Sort Key1:=S1.Range("IV2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
     
    S2.Range("A4:A" & S1.Range("IV65536").End(3).Row + 2).Value = S1.Range("IV2:IV" & S1.Range("IV65536").End(3).Row).Value
    S1.Range("IV:IV").Delete
    If S2.Range("IV3").End(1) = "TOPLAM" Then S2.Range("IV3").End(1).EntireColumn.Delete
 
    For X = 4 To S2.Range("A65536").End(3).Row
        For Y = 2 To S2.Range("IV3").End(1).Column
            If S2.Cells(3, Y) <> "TOPLAM" Then
                S2.Cells(X, Y) = Evaluate("=SUMPRODUCT(('" & S1.Name & "'!Y4:Y" & Son_Satır & "=""" & S2.Cells(X, 1) & """)*('" & S1.Name & "'!Z4:Z" & Son_Satır & "=""" & S2.Cells(3, Y) & """)*('" & S1.Name & "'!Q4:Q" & Son_Satır & "))")
            End If
        Next
    Next
    
    Son_Satır = S2.Range("A65536").End(3).Row + 1
    S2.Cells(Son_Satır, 1) = "TOPLAM"
    S2.Cells(Son_Satır, 1).Font.Bold = True
    S2.Cells(Son_Satır, 1).Interior.ColorIndex = 6
    Adres = "B" & Son_Satır & ":" & Cells(Son_Satır, Y).Address(0, 0)
    S2.Range(Adres).FormulaR1C1 = "=SUM(R[-35]C:R[-1]C)"
    S2.Range(Adres).Interior.ColorIndex = 6
    S2.Range(Adres).Font.Bold = True
    S2.Cells(3, 256).End(1).Offset(0, 1) = "TOPLAM"
    S2.Cells(3, 256).End(1).Offset(0, 0).Font.Bold = True
    S2.Cells(3, 256).End(1).Offset(0, 0).Interior.ColorIndex = 6
    Adres = Cells(4, Y).Address(0, 0) & ":" & Cells(Son_Satır, Y).Address(0, 0)
    S2.Range(Adres).FormulaR1C1 = "=SUM(RC[-14]:RC[-1])"
    S2.Range(Adres).Interior.ColorIndex = 6
    S2.Range(Adres).Font.Bold = True
    S2.Range("B3:IV3").HorizontalAlignment = xlCenter
    S2.Range("A3:" & Cells(S2.Range("A65536").End(3).Row, S2.Cells(3, 256).End(1).Column).Address(0, 0)).Borders.LineStyle = 1
    
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

erkanersoy · 29 Aralık 2010

Korhan Bey elinize emeğinize sağlık, kıymetli yardımlarınız için çok teşekkür ederim.

İki Tablo arasında senkronize ama koşullu :)

erkanersoy

Ekli dosyalar

Korhan Ayhan

Administrator

erkanersoy

erkanersoy

Korhan Ayhan

Administrator

erkanersoy

Ekli dosyalar

Korhan Ayhan

Administrator

erkanersoy

erkanersoy

Korhan Ayhan

Administrator

erkanersoy

erkanersoy

Ekli dosyalar

Korhan Ayhan

Administrator

erkanersoy

Ekli dosyalar

Korhan Ayhan

Administrator

erkanersoy