Makro ile çift sayıları ayırma

[halit3]

üstadım ufak bir sorunum var... A SÜTUNU MÜKERRERLERİ AYIRIRKEN, B SÜTUNU İÇİNDE DEĞİŞKEN VERİYİ MÜKERRER ATAMA YAPIYOR. ÖRNEK DOSYADA MAVİ OLAN YERLER MAKRO ÇALIŞTIKTAN SONRA MÜKERRER OLUYOR. SATIRDA HİÇBİR DEĞİŞİKLİK YAPMAMASI LAZIM. BİDE HOCAM HÜCRE GENİŞLEMESİ YAPAMADIM BİR TÜRLÜ. (V) SÜTUNUNA KADAR HİÇBİR HÜCRE SİLİNMEDEN DEĞİŞMEDEN AYNEN 2. SAYFAYA GEÇECEK. YAPAMADIM... YARDIMCI OLURSANIZ SEVİNİRİM.

Kırmızı yerleri değiştirdim.
Kod 1

Sub Makro1()


ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set s1 = Sheets("Sayfa1") ' veri sayfası
Set S2 = Sheets("Sayfa2") 'aktarılan sayfa

S2.Columns("A:Z").ClearContents

son1 = s1.Cells(Rows.Count, "A").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 1 To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "A"))
ara2(j) = 1
Next j

sat1 = 0

For r = 1 To son1
aranan1 = ara1(r)

sut13 = 0
sut14 = 0
sut15 = 0

If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
ara2(i) = 0
End If
Next i
sat1 = sat1 + 1
For t = 1 To [COLOR="red"]22[/COLOR]
S2.Cells(sat1, t).Value = s1.Cells(r, t).Value
Next

End If
Next r
S2.Columns("A:[COLOR="Red"]V[/COLOR]").EntireColumn.AutoFit
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub

Kod 2

Sub Makro2()
ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set s1 = Sheets("Sayfa1") ' veri sayfası
Set S2 = Sheets("Sayfa2") 'aktarılan sayfa

S2.Columns("A:F").ClearContents

son1 = s1.Cells(Rows.Count, "A").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 1 To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "A")) 
ara2(j) = 1
Next j

sat1 = 0

For r = 1 To son1
aranan1 = ara1(r)

sut13 = 0
sut14 = 0
sut15 = 0

If ara2(r) = 1 Then

deg = 0
For i = r To son1
If ara1(i) = aranan1 Then
deg = deg + 1
ara2(i) = 0
End If
Next i

If deg > 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sat1 = sat1 + 1
For t = 1 To [COLOR="red"]22[/COLOR]
S2.Cells(sat1, t).Value = s1.Cells([COLOR="red"]i[/COLOR], t).Value

Next

End If
Next i

End If


End If
Next r
S2.Columns("A:[COLOR="red"]V[/COLOR]").EntireColumn.AutoFit
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"


End Sub