B sütunundaki en son dolu hücreye göre a2:w? alanı

[velostar]

ekli dosyada stajyer listesi ve stajyer avukat yanı sayfalarında programdan aldığım raporlar bulunuyor. formüller sayfasında b sütununa stajyer sicil no yazarak bilgilerini ilgili yerlere çekiyorum. yapmak istediğim formüller sayfasında b sütunundaki en son dolu hücreye göre (örneğin 5 sicil girdim ve b6 hücresi en son dolu hücre oldu) a2:w6 alanını seçtirmek, salt metin sayfasında a satırı hariç mevcut verileri sildikten sonra formüller a2:w6 alanını salt metin sayfasına özel yapıştır/değerleri ve sayı biçimlendirmelerini şeklinde yapıştırıp salt metin sayfasını metin sekmeyle ayrılmış biçiminde excel dosyasının bulunduğu klasöre aynı isimle kaydedip kapatmak.

biraz uzun oldu ama bunların hepsini tek seferde yapabilirsem çok iyi olacak.

şimdiden teşekkürler.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu boş bir modüle ekleyip denermisiniz.

Not: Kodlar Sn. veyselemre beyin bir başlıktaki cevabından alıntıdır. Sadece sizin dosyanıza göre düzenleme yapılmıştır.

Sub VERİLERİ_TXT_DOSYASINA_AKTAR()
    On Error Resume Next
    BAŞLIK = Array("Baro Sicil No", "Staj Sicil No", "Ad", "Soyad", "Ruhsat İstem Tarihi", "Adliye Başlama Tarih", "Adliye Bitiş Tarih", "Staj Yaptığı Avukat", "Avukat Yanı Başlama Tarih", "Avukat Yanı Bitiş Tarih", "Adres", "İlçe", "İl", "TC Kimlik No", "Karar No", "Stajyer", "Stajyerin", "Stajyere", "Avukatı", "Doğum Yeri", "Doğum Tarihi", "Baba Adı", "Ana Adı")
    UZUNLUK = Array(20, 20, 20, 20, 30, 30, 30, 30, 30, 30, 30, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20)
    SON_SATIR = Sheets("Formüller").[B65536].End(3).Row
    If SON_SATIR = 1 Then
    MsgBox "AKTARILACAK VERİ BULUNAMAMIŞTIR !", vbExclamation
    Exit Sub: End If
    DOSYA_YOLU = ThisWorkbook.Path & "\"
    DOSYA_ADI = Replace(ActiveWorkbook.Name, ".xls", ".txt")
    Set ALAN = Sheets("Formüller").Range("A2:W" & SON_SATIR)
    Sheets("Salt Metin").Select
    [A2:W65536].ClearContents
    ALAN.Copy
    [A2].PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    [A1].Select
    Application.CutCopyMode = False
    HEDEF_DOSYA = DOSYA_YOLU & DOSYA_ADI
    Open HEDEF_DOSYA For Output As #1
    For SÜTUN = 1 To 23
    VERİ = VERİ & EŞİTLE(BAŞLIK(SÜTUN - 1), UZUNLUK(SÜTUN - 1))
    Next
    Print #1, VERİ
    
    For SATIR = 2 To [A65536].End(3).Row
    If Cells(SATIR, 1) <> "" Then
    VER&#304; = ""
    For S&#220;TUN = 1 To 23
    VER&#304; = VER&#304; & E&#350;&#304;TLE(Cells(SATIR, S&#220;TUN), UZUNLUK(S&#220;TUN - 1))
    Next
    Print #1, VER&#304;
    End If
    Next
    Close #1
    MsgBox "VER&#304;LER&#304;N&#304;Z  [ " & DOSYA_YOLU & " ]  KLAS&#214;R&#220;NE" & vbCrLf & _
    " [ " & DOSYA_ADI & " ] ADIYLA KAYIT ED&#304;LM&#304;&#350;T&#304;R.", vbInformation
End Sub

Function E&#350;&#304;TLE(G&#304;R&#304;&#350;, UZUNLUK)
    If UZUNLUK > Len(G&#304;R&#304;&#350;) Then
    E&#350;&#304;TLE = G&#304;R&#304;&#350; & String(UZUNLUK - Len(G&#304;R&#304;&#350;), " ")
    Else
    E&#350;&#304;TLE = Mid(G&#304;R&#304;&#350;, 1, UZUNLUK)
    End If
End Function

 

[velostar]

Sayın Cost_Control; emeğinize sağlık, tek bir sorun var. txt dosyasını adres mektup birleştimede kulanıyorum. alan ve kayıt sınırlayıcılarıyla ilgili bir sorunla karşılaştım ve çözemedim. dosyaya aktarırken belirli bir karakter yahut sekme kullanılabilmesi şansı var mı?

çok teşekkürler.