Makro ile ana sayfaya veri çekmek

[mustafa]

Merhaba,

Basketbol maçları ile ilgili bir dosyam var. Ana sayfada D2, E2 hücrelerine yazılacak takımların evlerinde ve deplasmanda oynadıkları son 5 maçın sonuçlarının Basketbol sayfasından aktarılmasını istiyordum. Sağolsun bir arkadaş yardım etti ve çok güzel oldu. Fakat dosya baya ağırlaştı, çok geç işlem yapmaya başladı. Basketbol sayfasında yaklaşık 12.000 satır var. Ana Sayfayı silince dosyada ağırlaşma sorunu gidiyor, fakat ana sayfa benim için çok önemli, vazgeçmek istemiyorum.

Basketbol sayfasındaki verilerden Ana Sayfaya aktarma işi makro ile yapılabilir mi? Eğer makro ile yapılabilirse dosyadaki ağırlaşma sorunu ortadan kalkar mı?

İşin kötüsü excelde çok acemiyim. Yardımcı olacaklara şimdiden çok teşekkür ederim.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[mustafa]

Hocam günaydın,

Cevap için çok teşekkür ederim.

Şu kod ilk maçları değil tarihe göre son maçlardan başlıyor, tarihe göre ilk maçtan başlamak için nasıl bir değiştirme gerekiyor?

Sub analiz()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("Basketbol")
sonn = s1.Range("e65536").End(xlUp).Row
s1.Range("z2:ab65536").ClearContents

sat = 2
For i = sonn To 4 Step -1
If s1.Cells(i, "e") <> "" Then
s1.Cells(i, "z") = s1.Cells(i, "e") & WorksheetFunction.CountIf(s1.Range("e" & sonn & ":e" & i), s1.Cells(i, "e"))
s1.Cells(i, "aa") = s1.Cells(i, "f") & WorksheetFunction.CountIf(s1.Range("f" & sonn & ":f" & i), s1.Cells(i, "f"))

If WorksheetFunction.CountIf(s1.Range("ab2:ab" & sonn), s1.Cells(i, "e")) = 0 Then
s1.Cells(sat, "ab") = s1.Cells(i, "e")
sat = sat + 1
End If

If WorksheetFunction.CountIf(s1.Range("ab2:ab" & sonn), s1.Cells(i, "f")) = 0 Then
s1.Cells(sat, "ab") = s1.Cells(i, "f")
sat = sat + 1
End If

End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Bir de dün dosyanın boyutu 3,50 mb iken sizin makroları ekleyince dosya boyutu 8,25 mb oldu. Bu normal mi? Makrolar mı dosyanın boyutunu artırdı?

 

[mustafa]

hocam şu kod son eklenen takıma en son numarayı veriyor, bunun yerine son eklenen takıma ilk numarayı verse sorun kalmıyor.

Sub analiz()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("Basketbol")
sonn = s1.Range("e65536").End(xlUp).Row
s1.Range("z2:ab65536").ClearContents

sat = 2
For i = sonn To 4 Step -1
If s1.Cells(i, "e") <> "" Then
s1.Cells(i, "z") = s1.Cells(i, "e") & WorksheetFunction.CountIf(s1.Range("e" & sonn & ":e" & i), s1.Cells(i, "e"))
s1.Cells(i, "aa") = s1.Cells(i, "f") & WorksheetFunction.CountIf(s1.Range("f" & sonn & ":f" & i), s1.Cells(i, "f"))

If WorksheetFunction.CountIf(s1.Range("ab2:ab" & sonn), s1.Cells(i, "e")) = 0 Then
s1.Cells(sat, "ab") = s1.Cells(i, "e")
sat = sat + 1
End If

If WorksheetFunction.CountIf(s1.Range("ab2:ab" & sonn), s1.Cells(i, "f")) = 0 Then
s1.Cells(sat, "ab") = s1.Cells(i, "f")
sat = sat + 1
End If

End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[mustafa]

ustalar şu sorunuma bi el atıverseniz.

Kod en alttan başlıyor takımları numaralandırmaya, en üstten numaralandırmaya başlaması için ne yapmak lazım?