Sheetslerdeki karışıklığa bulunan çözüm

[Ercan_ÇELİKOĞLU]

Sheetslerdeki karışıklığa eksik olan çözüm

Karışıklığa çözüm bulundu ancak örnek dosyada : 1987 yılında B12DE YAZILI İSİM A 12 VEYA Q12 BOŞ OLDUĞU İÇİN kod o ismi direk dışarı atıyor yani eklemiyor bu nedenle kodda nasıl bir değişiklik olursa boş olan A10:A65536 İLE Q10:Q65536 sütunlarına denk gelen b12:b65536 ya denk gelen isimler silinmeden oluşur? ilgili kod :
Sub DÜZENLE()
Sheets("Sayfa1").Select
Cells.Delete
[A1] = "SANDIK SİCİL NO"
[B1] = "ADI"
[C1] = "SOYADI"
SATIR = 2

On Error Resume Next
For SAYFA = 3 To Sheets.Count
Sheets(SAYFA).Range("A9:A65536").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
If Sheets(SAYFA).[A10] <> "" Then
SON_SATIR = Sheets(SAYFA).[A65536].End(3).Row
Sheets(SAYFA).Range("A10:C" & SON_SATIR).Copy Cells(SATIR, 1)
SATIR = [A65536].End(3).Row + 1
End If
Next

[A2:C65536].Sort Key1:=Range("B2"), Order1:=xlAscending
[A:C].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("F1"), Unique:=True
Range("E2") = 1
Range("E3") = 2
Range("E2:E3").AutoFill Destination:=Range("E2:E" & [F65536].End(3).Row)
Cells.EntireColumn.AutoFit

For X = 2 To [F65536].End(3).Row
For SAYFA = 3 To Sheets.Count
Set BUL = Sheets(SAYFA).[A:A].Find(Cells(X, "F"))
If Not BUL Is Nothing Then
ADRES = BUL.Address
Sheets(SAYFA).Cells(BUL.Row, "R") = Cells(X, "E")
Do
Set BUL = Sheets(SAYFA).[A:A].FindNext(BUL)
Loop While Not BUL Is Nothing And BUL.Address <> ADRES
End If
Next
Next

For SAYFA = 3 To Sheets.Count
Sheets(SAYFA).[A10:R65536].Sort Key1:=Sheets(SAYFA).[R10], Order1:=xlAscending
Next

For SAYFA = 3 To Sheets.Count
Sheets(SAYFA).Select
If [R65536].End(3).Value < Sheets("Sayfa1").[E65536].End(3).Value Then
For X = 1 To (Sheets("Sayfa1").[E65536].End(3).Value - [R65536].End(3).Value)
Cells([R65536].End(3).Row + 1, "R") = [R65536].End(3).Value + 1
Next
End If
For X = [R65536].End(3).Row To 10 Step -1
KONTROL = Cells(X, "R") - Cells(X - 1, "R")
If KONTROL <> 1 Then
Rows(X & ":" & X + KONTROL - 2).Insert
End If
Next
With Range("A10:Q259")
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Interior.Pattern = xlNone
End With
Next
MsgBox "VERİLERİNİZ DÜZENLENMİŞTİR.", vbInformation
End Sub

örbek dosya ektedir. acil çözüm arıyorum.

 

[Ercan_ÇELİKOĞLU]

lütfen çözüm

konu acil olduğu için yıpranmasını istemiyorum