kodlardaki revizyon hakkında

[amelie]

Arkadaşlar merhaba, geçenlerde Üstad Sayın Veysel Emre'nin yapmış olduğu kodlarda değişiklik yapmak istiyorum ( ki kendisine bir kez daha teşekkürü bir borç biliyorum) ancak başarılı olmadım ve yardımınızı rica ediyorum.
Yapmak istediğim değişiklik, mevcut data da z sütununa kadar olan bilgiler mevcuttur ancak benim eklemiş olduğum dosyac sütununa kadar olduğu için kodlar o şekilde düzenlendi Sayın Veysel Emre tarafından...Açıkçası ne yaptıysam da başarılı olamadım.

Saygılarımla.

Sub dene()

Application.ScreenUpdating = False
Sheets("59882HAV1").Copy after:=Sheets(Worksheets.Count)
Set s1 = ActiveSheet
For x = 2 To [a65536].End(3).Row
If Cells(x, 1) = "AMIR KAYITLAR " Or Cells(x, 1) = "LEHDAR KAYITLAR" Then
Cells(x, 1).Cut Cells(x, 3)
End If
Next x

[a65536].End(3).EntireRow.Delete
Range("c2:c" & [c65536].End(3).Row).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Range("c2:c" & [c65536].End(3).Row).Value = Range("c2:c" & [c65536].End(3).Row).Value
Dim rForDelete As Range
Dim c As Range
For Each c In Range("c2:c" & [c65536].End(3).Row)
If c.Offset(, -1) Like " *" Then
If rForDelete Is Nothing Then
Set rForDelete = c
Else
Set rForDelete = Union(rForDelete, c)
End If
End If
Next

If Not rForDelete Is Nothing Then rForDelete.EntireRow.Delete
Set rForDelete = Nothing

Columns("C:C").Cut
Columns("A:A").Insert Shift:=xlToRight

Application.DisplayAlerts = False
[a1] = "Cinsi"
s1.[a:c].Sort Key1:=s1.Range("A2"), Order1:=xlAscending, header:=xlYes
s1.Copy after:=Sheets(Sheets.Count)
On Error Resume Next
basla:
Set s1 = ActiveSheet
isim = s1.[a2]
Sheets(isim).Delete
Err = 0
s1.Name = isim
Set adr = Intersect(s1.Range("a:a").ColumnDifferences(s1.[a2]), s1.[2:65536]).EntireRow

If Err = 0 Then
Set s2 = Sheets.Add
s1.Rows(1).Copy s2.[a1]
adr.Cut s2.[a2]
GoTo basla
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub