Puan Hareketleri

[erhan1232]

Elimdeki 2 Liste var biri Ocak ayında alınan isim ve puan bilgisi listesi digeri ise Şubat ayında alınan isim ve puan bilgisi listesi. Ocak ve şubat ayındaki puanlarda bir degişiklik oldu ise bu kişileri 3. bir sheete yüklenmesini istiyorum..

Ekte örnek bulunmaktadır şimden yardımcı olan arkadaşlara teşekkürler..

 

[muygun]

Merhaba;
Eki inceleyin. (gri hücreleri yeterince aşağı doğru çoğaltın.)
İyi çalışmalar.

 

[erhan1232]

Çok teşekkürler 30,000 kişilik listeyi bu programla yapabilirmiyim?

 

[muygun]

Verilerin tabloyu ne kadar ağırlaştıracağını , Kullandığınız bilgisayarın performansını bilemem. Bunu öğrenmenin yolu denemek...

 

[erhan1232]

35.000 kayıt programı çok yavaşlatıyor bu programı macro ile yapabilirmiyiz? Şimdiden çok teşekkürler..

 

[Orion1]

Makro ile dosyanız ektedir.
Kişileri kart no'larına göre arıyor.

Sub degisiklikleri_aktar()
Dim k As Range, sat1 As Long, sat2 As Long, sat3 As Long, i As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Sheets("Puan hareketi").Select
Application.ScreenUpdating = False
Set sh1 = Sheets("Liste1 Ocak")
Set sh2 = Sheets("Liste2 şubat")
Range("A2:D65536").ClearContents
sat1 = sh1.Cells(65536, "A").End(xlUp).Row
sat2 = sh2.Cells(65536, "A").End(xlUp).Row
sat3 = 2
For i = 2 To sat1
    Set k = sh2.Range("A2:A" & sat2).Find(sh1.Cells(i, "A").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        If sh1.Cells(i, "D").Value <> sh2.Cells(k.Row, "D").Value Then
            Range("A" & sat3 & ":D" & sat3).Value = sh2.Range("A" & k.Row & ":D" & k.Row).Value
            sat3 = sat3 + 1
        End If
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Değişiklikler aktarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[erhan1232]

Makro ile dosyanız ektedir.
Kişileri kart no'larına göre arıyor.

Sub degisiklikleri_aktar()
Dim k As Range, sat1 As Long, sat2 As Long, sat3 As Long, i As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Sheets("Puan hareketi").Select
Application.ScreenUpdating = False
Set sh1 = Sheets("Liste1 Ocak")
Set sh2 = Sheets("Liste2 şubat")
Range("A2:D65536").ClearContents
sat1 = sh1.Cells(65536, "A").End(xlUp).Row
sat2 = sh2.Cells(65536, "A").End(xlUp).Row
sat3 = 2
For i = 2 To sat1
    Set k = sh2.Range("A2:A" & sat2).Find(sh1.Cells(i, "A").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then
        If sh1.Cells(i, "D").Value <> sh2.Cells(k.Row, "D").Value Then
            Range("A" & sat3 & ":D" & sat3).Value = sh2.Range("A" & k.Row & ":D" & k.Row).Value
            sat3 = sat3 + 1
        End If
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Değişiklikler aktarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

Çook teşekkürler program işimi gördü..

 

[Orion1]

Çook teşekkürler program işimi gördü..

Rica ederim.
İyi çalışmalar.