Koşullu Satır Silme

[fealdown]

İyi günler kolay gelsin,şimdi benim hak.xlsx(boş halini linkte gönderiyorum) adında dosyam var.bu dosyamdan birsürü var içi dolu halinde.dosyada işaretlediğim mavi alanları kontrol edilecek ve boş ise o satırı komple silecek eğer mavi hücre dolu ise silmeyek.Ve bunu ayrı bir excelden makro ile yapmam lazım.Yardımcı olabilir misiniz ?(renklendirmeyi anlatabilmek için yaptım )

dosyam:
http://www.dosya.tc/server15/fhecbj/hak.xlsx.html

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodlar ile yapabilirsiniz.

Set f = ds.getfolder("C:\Klasör") satırını düzenlemeyi unutmayın.

Sub DosyaAc_SatirSil()
Dim ds, dc, f, Uzanti
Dim xDosya As Workbook
Dim xSayfa As Worksheet
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.getfolder("C:\Klasör") 'Buraya dosyalarınızın bulunduğu klasör yolunu yazınız.
Set dc = f.Files
For Each dosya In dc
Uzanti = VBA.Right(dosya, 4)
If Uzanti = "xlsm" Or Uzanti = "xlsx" Or Uzanti = ".xls" Then
Set xDosya = Workbooks.Open(dosya)
Set xSayfa = xDosya.Worksheets("TADİLAT İŞLERİ")
BosSatirSil xSayfa
xDosya.Close True
End If

Next
End Sub

Sub BosSatirSil(xSayfa As Worksheet)
Dim Bak As Long
For Bak = xSayfa.Cells(xSayfa.Rows.Count, "A").End(3).Row + 1 To 1 Step -1
If IsNumeric(xSayfa.Cells(Bak, 1).Value) And xSayfa.Cells(Bak, 3).Value = "" Then
If xSayfa.Cells(Bak, 1).Value > 2 Then
xSayfa.Rows(Bak).Delete
End If
End If
Next
End Sub

 

[fealdown]

Set f = ds.getfolder("C:\Klasör") 'Buraya dosyalarınızın bulunduğu klasör yolunu yazınız.

bu alan yerine Application.GetOpenFilename ile kendimiz seçemez miyiz istediğimiz dosyayı ?

 

[Muzaffer Ali]

O zaman "DosyaAc_SatirSil" altındaki kodları aşağıdaki ile değiştirin.

Sub DosyaAc_SatirSil()
    Dim Dosya As String
    Dim xDosya As Workbook
    Dim xSayfa As Worksheet
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm")
    Set xDosya = Workbooks.Open(Dosya)
    Set xSayfa = xDosya.Worksheets("TADİLAT İŞLERİ")
    BosSatirSil xSayfa
    xDosya.Close True
End Sub

 

[fealdown]

sağolun böylede çalışıyor ama MultiSelect özelliğini açtığımda hata alıyorum bütün dosyayı tek tek açmak zor oluyor

 

[Muzaffer Ali]

Sub DosyaAc_SatirSil()
    Dim Dosya() As Variant
    Dim xDosya As Workbook
    Dim xSayfa As Worksheet
    Dim Bak As Long
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=True)
    For Bak = 1 To UBound(Dosya)
        Set xDosya = Workbooks.Open(Dosya(Bak))
        Set xSayfa = xDosya.Worksheets("TADİLAT İŞLERİ")
        BosSatirSil xSayfa
        xDosya.Close True
    Next
End Sub

 

[fealdown]

emeğiniz için teşekkür ederim çok sağolun