Makro istenilen islemi eksik yapiyor

[arkanonur]

Merhaba Arkadaslar,

Ektede gorebileceginiz gibi isimlerle ilgili bir makro yazdim.
Makro soyle calisiyor:

1) Sheet 6'daki pivot tablosunu Chart_3 adi altinda bir sayfa acip oraya kopyaliyor.

2) Names sayfasindaki "E" sutununa bakiyor. Eger E sutununa hicbir veri girilmemisse makro hicbir aktivite yapmiyor.

3) Eger "E" sutununa bir veri girilmisse H sutunundaki soyad-ad kombinasyonunu Chart_3'deki "A" sutunundaki ad ve soyad kombinasyonunda buluyor ve o satiri siliyor.

Burda yapilmak istenen islem, artik kullanilmayan isimleri olusturulacak grafik icin elemek.

Ancak, denemek icin "names" sayfasindaki tum isimleri silinsin diye "E" sutununa isaretledim ama hala silinmeyen bir suru isim var. Bunun nedenini saatlerdir ariyorum cozemedim. Bana yardimci olabilirseniz cok sevinirim.

Saygilar,

Onur Arkan

 

[Korhan Ayhan]

Selamlar,

Anladığım kadarıyla kodunuzu düzenlemeye çalıştım incelermisiniz.

Sub Chart3()
    Application.ScreenUpdating = False
    Dim SON1 As Integer
    Dim SON2 As Integer
    
    Sheets("Sheet6").Select
    SON1 = [a65536].End(3).Row
    Range(Cells(4, 1), Cells(SON1, 5)).Select
    Selection.Copy
    Range("A1").Select
    Sheets.Add
    ActiveSheet.Name = "Chart3_Data"
    Range("A1").Select
    ActiveSheet.Paste
    Cells.EntireColumn.AutoFit

    Sheets("names").Select
    Columns("H").ClearContents
    SON2 = [a65536].End(3).Row
    
    For i = 2 To SON2
    Range("H" & i).Value = Range("B" & i).Value + " " + Range("C" & i).Value
    Next i
    Range("A1").Select
    
    Sheets("Chart3_Data").Select
    For i = 2 To SON1
    If Sheets("names").Range("E" & i) = "" Then
    Else
        KRİTER = Sheets("names").Range("H" & i).Value
        Range("A1").Select
        On Error Resume Next
        Cells.Find(What:=KRİTER, After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.EntireRow.Delete Shift:=xlUp
    End If
    Next i
    Range("A1").Select
    Application.ScreenUpdating = True
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR..."
End Sub

 

[arkanonur]

makro hakkinda

Sevgili Cost Control,

Makro mukemmel calisiyor , cok tesekkur ederim.

Saygilar,

Onur Arkan