Bir sütunda istenilen satırları almasın

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar; aşağıdaki kodla Belgelerim de bulunan PROMOSYON TXT dosyasına personel listemdeki kişiler için Promosyon ödemesi için veriler gönderiyor, ancak benim isteğim listemde “S” Sütununda “ÜCRETSİZ İZİNLİ” olanları göndermesin yani ücretsiz izinde olanlara 60 lira promosyon verilmeyecek bunun için aşağıdaki kodda nasıl bir değişiklik yapılır. Saygılarımla.

Sub PROMOSYON_İÇİN_TXT_GÖNDER()
Dosya = "D:\Belgelerim\Banka\PROMOSYON TXT.xls"
SonSat = Cells(Rows.Count, "A").End(3).Row
'-----------------------------------------------------
'düzenleyen paraflarıda kaydedilecekse
'sonsat = Range("B:H").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'-----------------------------------------------------
Set aç = New Excel.Application
aç.Workbooks.Open Dosya
Set hz = aç.Workbooks(Dir(Dosya))
Set syf = hz.Sheets(1)

syf.Range("A6:F" & 65536) = Empty

Dim a
a = InputBox("ÖDEME TARİHİNİ GİRİNİZ", "LÜTFEN DİKKAT", Date + 2)
syf.Range("G2").Value = a

For t = 2 To SonSat

‘S sütununda bulunan ÜCRETSİZ İZİNLİ olanları almasın

syf.Range("A" & t + 4).Value = Range("C" & t).Value & " " & Range("D" & t).Value
Next
syf.Range("D6" & SonSat + 4).Value = Range("K2:K" & SonSat).Value
syf.Range("E6:E" & SonSat + 4).Value = "60"
syf.Range("F6:F" & SonSat + 4).Value = "Promosyon Ödemesi"
syf.Range("H6:H" & SonSat + 4).Value = "İşyeri Çalışanı"

hz.Close SaveChanges:=True
aç.Quit
Set aç = Nothing: Set hz = Nothing

MsgBox "Banka Listesi; TXT Dosyası oluşturmak için Bankanın Formatına Gönderildi." & vbCrLf & "Şimdi verileri Bankaya Göndermek İçin Kontrol Edin."

End Sub

 

[YUSUF44]

syf.Range("A" & t + 4).Value = Range("C" & t).Value & " " & Range("D" & t).Value

satırını

If syf.Cells(t + 4, "S") <> "ÜCRETSİZ İZİNLİ" Then
    syf.Range("A" & t + 4).Value = Range("C" & t).Value & " " & Range("D" & t).Value
End If

olarak değiştirip deneyin. (Siz t+4 olarak kullandığınız için ben de t+4 olarak kullandım)

 

[Hacı Bayram ÖZKAN]

Yusuf abiciğim olmadı dosyaları atıyorum bakar mısın? Zahmet olmaz ise... Teşekkürler. Diğer dosyayı kabul etmedi abim

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Sub PROMOSYON_İÇİN_TXT_GÖNDER()
Dosya = "D:\Belgelerim\Banka\PROMOSYON TXT.xls"
sonsat = Cells(Rows.Count, "A").End(3).Row
'-----------------------------------------------------
'düzenleyen paraflarıda kaydedilecekse
'sonsat = Range("B:H").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'-----------------------------------------------------
Set aç = New Excel.Application
aç.Workbooks.Open Dosya
Set hz = aç.Workbooks(Dir(Dosya))
Set syf = hz.Sheets(1)

syf.Range("A6:F" & 65536) = Empty

Dim a
a = InputBox("ÖDEME TARİHİNİ GİRİNİZ", "LÜTFEN DİKKAT", Date + 2)
syf.Range("G2").Value = a

For t = 2 To sonsat
'S sütununda bulunan ÜCRETSİZ İZİNLİ olanları almasın
    syf.Range("A" & t + 4).Value = Range("C" & t).Value & " " & Range("D" & t).Value
Next
syf.Range("D6:D" & sonsat + 4).Value = Range("K2:K" & sonsat).Value
syf.Range("E6:E" & sonsat + 4).Value = "60"
syf.Range("F6:F" & sonsat + 4).Value = "Promosyon Ödemesi"
syf.Range("H6:H" & sonsat + 4).Value = "İşyeri Çalışanı"
For j = sonsat To 2 Step -1
    If Cells(j, "S") = "ÜCRETSİZ İZİNLİ" Then
        syf.Rows(j + 4).Delete
    End If
Next
    
hz.Close SaveChanges:=True
aç.Quit
Set aç = Nothing: Set hz = Nothing

MsgBox "Banka Listesi; TXT Dosyası oluşturmak için Bankanın Formatına Gönderildi." & vbCrLf & "Şimdi verileri Bankaya Göndermek İçin Kontrol Edin."

End Sub

 

[Hacı Bayram ÖZKAN]

Yusuf bey Bankanın formatı değişik bir dosya siteye bile atamadım, vba sı kapalı kendi dosyamdaki verileri buraya gönderiyordum burdan TXT yapıyordu, 1. mesajımdaki kodla verileri bu dosyaya gönderiyor buradan işlem yapıyordum, sizin değişiklikle sadece ücretsiz izinleri atmayacak ama aşağıdaki hatayı verdi. Eğer sizin yazdığınız kodla ücretsiz izinleri alıp komple silecek o dosya bu işlemi normalde de yapmıyor.
Range sınıfının delete yönetimi başarısız dedi ve
syf.Rows(j + 4).Delete
bu satırda sarı yandı.
Abi o dosyayı buraya attım bakar mısın?

PROMOSYON_TXT.xls dosyasını indir - download

PROMOSYON_TXT.xls dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[YUSUF44]

O dosyayı indirmedim, muhtemelen satır silme engellendiği için hata vermiştir.

Aşağıdaki kodu dener misiniz?

Sub PROMOSYON_İÇİN_TXT_GÖNDER()
Dosya = "D:\Belgelerim\Banka\PROMOSYON TXT.xls"
sonsat = Cells(Rows.Count, "A").End(3).Row
'-----------------------------------------------------
'düzenleyen paraflarıda kaydedilecekse
'sonsat = Range("B:H").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'-----------------------------------------------------
Set aç = New Excel.Application
aç.Workbooks.Open Dosya
Set hz = aç.Workbooks(Dir(Dosya))
Set syf = hz.Sheets(1)

syf.Range("A6:F" & 65536) = Empty

Dim a
a = InputBox("ÖDEME TARİHİNİ GİRİNİZ", "LÜTFEN DİKKAT", Date + 2)
syf.Range("G2").Value = a
sat = 6
For t = 2 To sonsat
'S sütununda bulunan ÜCRETSİZ İZİNLİ olanları almasın
    If Cells(t, "S") <> "ÜCRETSİZ İZİNLİ" Then
        syf.Range("A" & sat).Value = Range("C" & t).Value & " " & Range("D" & t).Value
        syf.Range("D" & sat).Value = Range("K" & t).Value
        syf.Range("E" & sat).Value = "60"
        syf.Range("F" & sat).Value = "Promosyon Ödemesi"
        syf.Range("H" & sat).Value = "İşyeri Çalışanı"
        sat = sat + 1
    End If
Next
    
hz.Close SaveChanges:=True
aç.Quit
Set aç = Nothing: Set hz = Nothing

MsgBox "Banka Listesi; TXT Dosyası oluşturmak için Bankanın Formatına Gönderildi." & vbCrLf & "Şimdi verileri Bankaya Göndermek İçin Kontrol Edin."

End Sub

 

[Hacı Bayram ÖZKAN]

Sayın abim çalıştı eline sağlık çok teşekkür ederim. dua ile kal zahmet verdim hakkını helal et..