• DİKKAT

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

Formül ile yapılan işlemleri makroya çevirmek

Merhaba,

Önce formülleri yardımcı sütunları ve koşullu biçimlendirmeleri silin, daha sonra kodu çalıştırın.

Kod:
Option Explicit
 
Sub SiralaSay()
Dim S1 As Worksheet, S2 As Worksheet
Dim i As Long, son As Long, son1 As Long, sat As Long
 
Set S1 = Sheets("Sayfa1"): Set S2 = Sheets("Sayfa2")
 
Application.ScreenUpdating = False
 
son = S1.[E65536].End(3).Row
S2.Range("A2:C65536").ClearContents
S2.Range("A:C").Borders.LineStyle = 0
 
sat = 1
For i = 3 To son
[COLOR=red]S1.Cells(i, "E") = Right(S1.Cells(i, "E"), 10)[/COLOR]
    If WorksheetFunction.CountIf(S1.Range("E3:E" & i), S1.Cells(i, "E")) = 1 Then
        sat = sat + 1
        S2.Cells(sat, "A") = S1.Cells(i, "E")
    End If
Next i
 
son1 = S2.[A65536].End(3).Row
 
For i = 2 To son1
    S2.Cells(i, "B") = WorksheetFunction.CountIf(S1.Range("E3:E" & son), S2.Cells(i, "A"))
    S2.Cells(i, "C") = WorksheetFunction.SumIf(S1.Range("E3:E" & son), S2.Cells(i, "A"), S1.Range("G3:G" & son))
Next i
 
S2.Range("A1:C" & son1).Borders.LineStyle = 1
Application.ScreenUpdating = True
End Sub
.
 
Selamlar,

Hocam sağolun vermiş oldugunuz bilgiler ve çalışma için..

İyi Günler Dilerim :)
 

Ekli dosyalar

Selamlar,

Yurttaş Hocam Sağolun çalışmanız ve verdiğiniz linkler için Allah Razı Olsun...
 
Selamlar,

Benmi dosya üzerinde bazı yapmam gereken değişiklikler varda onu bir türlü yapmamadım....

sayfa 1 e sutununda bulunan numaralrın 10 haneli olması...
formül ile çözüdm ama bir türlü formülü makro olarak uygulayamdım...
 

Ekli dosyalar

Merhaba,

#2 nolu mesaja ilaveyi kırmızı ile işaretledim..

.
 
Selamlar,

Sağolun hocam
 
Geri
Üst