Excel Vba Yardım

[valentino06]

Merhaba,
Hayırlı akşamlar arkadaşlar ekteki dosya kullanmış olduğum bir makro var ben excel sayfasındaki "A" sütunundaki 20000 ile başlayanlar kalsın boş olanları silmek istiyorum. lütfen yardımcı olabilir misiniz.

http://s8.dosya.tc/server2/92921d/ORNEK.xlsm.rar.html

 

[valentino06]

Arkadaşlar lütfen yardımcı olabilir misiniz.

 

[alicimri]

Sayın valentino06
Aşağıdaki kod işinize yarar herhalde.

Sub KYNK()
SAY = Range("b65536").End(3).Row
acik = False
For i = 7 To SAY
If Range("C" & i) = "KAYNAK GRUBU" And Left(Range("A" & i), 7) = "2000000" Then
acik = True
ElseIf Range("C" & i) = "KAYNAK GRUBU" And Range("A" & i) = 0 Then
acik = False
End If
If acik = False Then
Range("I" & i).Value = 1
End If
Next
For i = SAY To 7 Step -1
If Range("I" & i).Value = 1 Then
Rows(i & ":" & i).Delete
End If
Next
End Sub

 

[valentino06]

Merhaba,
Ali bey çok teşekkür ederim bu kodu buton eklemeden yapma şanşımız var mı hatta var olan kodu sayfa içinde butona bağlamadan çalışmasını sağlayabilir miyiz. yardımlarınız için ne kadar teşekkür etsem azdır. Allah işinizi gücünüzü rast getirsin.

 

[alicimri]

Sayın valentino06
Makro kaydet'e tıklayın, kısayol tuşu atayın, makro kaydet'i durdurun. Yukardaki makroyu bu boş makronun içine yapıştırın. Bir butona bağlamadan kısayol tuşları ile kodları çalıştırabilirsiniz.

 

[valentino06]

Ali bey çok teşekkür ederim.

 

[veyselemre]

Ali Bey sorunu gayet güzel çözmüş geceyarısı ama güzel soru, alternatif...

Sub test()
    Set Sec = Range("C7:C" & Cells(Rows.Count, 2).End(3).Row)
    sil = True
    For Each huc In Sec
        If huc.Value = "KAYNAK GRUBU" Then
            If Left(huc.Offset(, -2).Value, 7) = "2000000" Then
                sil = False
            Else
                sil = True
            End If
        End If
        If sil Then huc.ClearContents
    Next huc
    If WorksheetFunction.CountBlank(Sec) > 0 Then Sec.SpecialCells(4).EntireRow.Delete
End Sub

 

[valentino06]

Çok teşekkür ederim. Veysel bey bu listede daha önce Halit beyin yapmış olduğu sıralamayı kullanıyordum. şimdi kullanmak istiyorum. fakat verileri sıralamıyor. ve verileri siliyor. lütfen yardımcı olabilir misiniz.

Sub sirala()
ZBasla = TimeValue(Now)
zaman = Timer

sut1 = "a" 'başlangıç sutün
sut2 = "b" 'Taranacak sutün
sut3 = "K" 'yardımcı sutün

sat1 = 7 'başlangıç satır


Set Sh1 = Sheets(ActiveSheet.Name) 'sayfa adı
son = Sh1.Cells(Rows.Count, sut1).End(3).Row 'son dolu satır

Sh1.Range(Sh1.Cells(sat1, sut3), Sh1.Cells(son, sut3)).Clear


Range(sut2 & sat1 & ":" & sut2 & son).Copy
Cells(7, sut3).PasteSpecial Paste:=2
Application.CutCopyMode = False

For j = sat1 To son

deg2 = Split(Sh1.Cells(j, sut2), "KG")
If UBound(deg2) > 0 Then
deg3 = deg2(0) & "KG" & Format(deg2(1), "000")
End If
Sh1.Cells(j, sut2) = deg3 '"h" & Format(deg3, "0000000000000")
Next j

Range("A7:" & sut3 & son).Sort Key1:=Cells(7, sut2), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

Range(sut3 & sat1 & ":" & sut3 & son).Copy
Cells(7, sut2).PasteSpecial Paste:=2
Application.CutCopyMode = False
    
Range("a1").Select


Sh1.Range(Sh1.Cells(sat1, sut3), Sh1.Cells(son, sut3)).Clear
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

 

[veyselemre]

Kodu incelemedim ama, A sutunu boş olduğu için hatalı son satır buluyor olabilir, aşağıdaki gibi deneyin.

 son = Sh1.Cells(Rows.Count, [COLOR="Red"]3[/COLOR]).End(3).Row    'son dolu satır

 

[valentino06]

Veysel bey bu seferde b sütunundaki düzeltmesi gereken verileri siliyor.

 

[veyselemre]

Kodu boş verin siz ne yapmak istiyorsunuz, yeni bir başlıkta dosya ekleyerek, görmek istediğiniz, sonucu da belirterek sorarsanız mutlaka birileri yardımcı olur.

 

[valentino06]

Tamam teşekkür ederim.