Hucrenin altinda veri yok ise diger sutundaki veriyi ilk satirda birlestir

[fredycrouger]

Merhaba,

Sistemden aldigimiz bir rapor var ve ne yazik ki bu raporun olusturulma seklini degistiremiyoruz. Bu sebeple her seferinde Excel uzerinde ayni islemleri manuel olarak yapmak zorunda kaliyoruz. Ekledigim dosyada ornek mevcut.

Yapmak istedigim islem asagidaki gibidir:

ornek:
A2 sutununda hucrenin alti bos ise ve T2 hucresinde veri var ise A sutunundaki bir sonraki veri olan hucreye kadar T2 hucresindeki ve altindaki verileri ilk satirda, yani T2 hucresinde birlestirmek istiyorum.

Eger A2 hucresinin alti bos degilse bir islem yapmaya gerek yok, A3 ten devam edecek, bu sekilde A sutunundaki son satira kadar ayni islemi yapacak (A sutununda binlerce veri olacak ve son satir her seferinde farkli olacak).

Ornek dosya: https://easyupload.io/0piw1a

Yardimlariniz icin simdiden cok tesekkur ederim.

 

[ÖmerFaruk]

Aşağıdaki kodu boş bir modüle içine ekleyip çalıştırabilirsiniz.

1. Verileriniz Air sayfasında A2:Txx aralığında olduğu varsayılarak.
2. Sonuc yine aynı sayfada U2:Vx aralığında hazırlandı. Gerekli açıklmayı kod içinde belirttim.

Sub RaporDuzenle()
    Dim Sh As Worksheet, i As Long, Say As Long
    Set Sh = Worksheets("Air")
    Arr = Sh.Range("A2:T" & Sh.Range("T" & Rows.Count).End(3).Row)
    ReDim Liste(1 To UBound(Arr), 1 To 2)
    For i = 2 To UBound(Arr)
        If Arr(i, 1) <> "" Then
            Say = Say + 1
            Liste(Say, 1) = Arr(i, 1)
        End If
        Liste(Say, 2) = Liste(Say, 2) & Arr(i, 20)
    Next i
    
    'Aynı sayfada U2:Vxx aralığına sonucu yazdırdım.
    'Başka bir sayfa ve/veya alana kaydetmek istiyorsanız ona göre uyarlamalısın
    Sh.Range("U2:V" & Rows.Count).ClearContents
    Sh.Range("U2").Resize(Say, 2) = Liste
    '...................................................
    
    Erase Liste: Erase Arr: i = Empty: Say = Empty: Set Sh = Nothing
End Sub

 

[fredycrouger]

Aşağıdaki kodu boş bir modüle içine ekleyip çalıştırabilirsiniz.

1. Verileriniz Air sayfasında A2:Txx aralığında olduğu varsayılarak.
2. Sonuc yine aynı sayfada U2:Vx aralığında hazırlandı. Gerekli açıklmayı kod içinde belirttim.

Sub RaporDuzenle()
    Dim Sh As Worksheet, i As Long, Say As Long
    Set Sh = Worksheets("Air")
    Arr = Sh.Range("A2:T" & Sh.Range("T" & Rows.Count).End(3).Row)
    ReDim Liste(1 To UBound(Arr), 1 To 2)
    For i = 2 To UBound(Arr)
        If Arr(i, 1) <> "" Then
            Say = Say + 1
            Liste(Say, 1) = Arr(i, 1)
        End If
        Liste(Say, 2) = Liste(Say, 2) & Arr(i, 20)
    Next i
   
    'Aynı sayfada U2:Vxx aralığına sonucu yazdırdım.
    'Başka bir sayfa ve/veya alana kaydetmek istiyorsanız ona göre uyarlamalısın
    Sh.Range("U2:V" & Rows.Count).ClearContents
    Sh.Range("U2").Resize(Say, 2) = Liste
    '...................................................
   
    Erase Liste: Erase Arr: i = Empty: Say = Empty: Set Sh = Nothing
End Sub

@ÖmerFaruk bey elinize saglik yalniz soyle bir sorun var. BK sutununa kadar veri oldugu icin sonuclarin BL ve BM sutununa olusturulmasi icin degisiklik yaptim. Fakat Client isimlerinin siralamasi degisti, diger sutunlarda da veri oldugu icin ayni satirda olmasi gerekli yoksa tum bilgiler birbirine giriyor. Ayrica A sutununda bos olan satirlari sonradan silecegim icin her client icin en ust satirda verileri birlestiriyorum. Sonuc listesinde aradaki bosluklar olmadigi icin durum biraz karisti. Sonuclar ornek dosyada oldugu gibi A sutunu ile ayni satirda olmali.

Emeginiz icin cok tesekkurler!

 

[ÖmerFaruk]

Sub RaporDuzenle2()
    Dim Sh As Worksheet, i As Long, Say As Long
    Set Sh = Worksheets("Air")
    Arr = Sh.Range("A2:T" & Sh.Range("T" & Rows.Count).End(3).Row)
    ReDim Liste(1 To UBound(Arr), 1 To 2)
    For i = 2 To UBound(Arr)
        If Arr(i, 1) <> "" Then
            Say = i
            Liste(Say, 1) = Arr(i, 1)
        End If
        Liste(Say, 2) = Liste(Say, 2) & Arr(i, 20)
    Next i
    Sh.Range("BL2:BM" & Rows.Count).ClearContents
    Sh.Range("BL2").Resize(UBound(Arr), 2) = Liste
    '...................................................
    
    Erase Liste: Erase Arr: i = Empty: Say = Empty: Set Sh = Nothing
End Sub

 

[fredycrouger]

Sub RaporDuzenle2()
    Dim Sh As Worksheet, i As Long, Say As Long
    Set Sh = Worksheets("Air")
    Arr = Sh.Range("A2:T" & Sh.Range("T" & Rows.Count).End(3).Row)
    ReDim Liste(1 To UBound(Arr), 1 To 2)
    For i = 2 To UBound(Arr)
        If Arr(i, 1) <> "" Then
            Say = i
            Liste(Say, 1) = Arr(i, 1)
        End If
        Liste(Say, 2) = Liste(Say, 2) & Arr(i, 20)
    Next i
    Sh.Range("BL2:BM" & Rows.Count).ClearContents
    Sh.Range("BL2").Resize(UBound(Arr), 2) = Liste
    '...................................................
   
    Erase Liste: Erase Arr: i = Empty: Say = Empty: Set Sh = Nothing
End Sub

@ÖmerFaruk Harikasiniz, elinize saglik. Cok ama cok tesekkurler!

Saygilar!