"merge" a,b,c Sütunundaki satırları boş olan hücreyi dolu olan hücre ile birleştirme

[isakaratastan]

Merhaba,
benim sorunum, "A" sütunundan son dolu sütununa kadar 1.000 satırlık verim mevcut. ilk dolu satırın bir altından itibaren son dolu satıra kadar araya bir boş satır eklesin sonrada A,B ve C sütunundaki ilk boş hücreyi ilk dolu hücre ile birleştirsin. sonra ayın birinden itibaren son gününe kadar olan bölümde rakam harici herhangi bir harf varsa silsin ve rakam kalan hücrelerin bir üstüne X yazsın.
birleştirme işlemi hariç diğer işlemleri parça parça yapıyorum ama hepsini bir butonda birleştiremedim.
Örnek dosya ektedir. yardımcı olursanız sevinirim. (renklendirdiğim yer gibi makroda yapmaya çalışıyorum)

 

[Muzaffer Ali]

Merhaba.
Deneyiniz.

Sub Test()
    Dim Bak As Long
    Dim BakGun As Integer

    Application.ScreenUpdating = False
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 6 Step -1
        Rows(Bak + 1).Insert
        Range("A" & Bak & ":A" & Bak + 1).Merge
        Range("B" & Bak & ":B" & Bak + 1).Merge
        Range("C" & Bak & ":C" & Bak + 1).Merge
   
        For BakGun = 4 To 35
            If IsNumeric(Cells(5, BakGun)) Then
                If IsNumeric(Cells(Bak, BakGun)) And Not IsEmpty(Cells(Bak, BakGun)) Then
                    Cells(Bak + 1, BakGun) = Cells(Bak, BakGun)
                    Cells(Bak, BakGun) = "x"
                ElseIf Not IsEmpty(Cells(Bak, BakGun)) Then
                    Cells(Bak, BakGun) = ""
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

 

[isakaratastan]

Hocam tam talep ettiğim gibi harika olmuş.
Üstüne ekleyecek olursak bu işlemi, ayın birinden itibaren son gününe kadar olan bölümde rakam harici herhangi bir harf varsa veya boşsa ve GÇ balıklı sütunda karşısına gelen hücrede boşsa satırı komple sildikten sonra bu işlemler yapılma imkanı var mı.
özetlemek gerekirse Tarık'ın ay içinde mesaisi yoksa karşına denk gelen GÇ başlıklı hücrede boşsa o satır komple silinsin gibisinden.

veya daha kolay olacaksa farklı bir sayfaya ham veriden sadece özetlediğim durum ve istediğimiz başlıklardaki veriler Listboxta eklediğim örnek dosyadaki E ve D sütunundaki seçilen tekli veya çoklu kriterler göre yukarıdaki işlemi uygulaya bilir miyiz,

Örnekleyecek olursak listboxtan Birim 1 in alt kırılımı (görevi) sadece Şoför veya seçim yaptığım diğer kriterlere veya 1 ve 2 seçtiğim zaman onların alt kırılımında seçili kritrlere göre gelmesi gibi
Biraz uzun oldu ama İnşallah anlatmışımdır.
olmama gibi durum varsa sadece "Hocam tam talep ettiğim gibi harika olmuş.
Üstüne ekleyecek olursak bu işlemi, ayın birinden itibaren son gününe kadar olan bölümde rakam harici herhangi bir harf varsa veya boşsa ve GÇ balıklı sütunda karşısına gelen hücrede boşsa satırı komple sildikten sonra bu işlemler yapılma imkanı var mı.
özetlemek gerekirse Tarık'ın ay içinde mesaisi yoksa karşına denk gelen GÇ başlıklı hücrede boşsa o satır komple silinsin gibisinden." bu bile olsa işim baya kolaylaşıyor.

 

[Muzaffer Ali]

Yeni kodlar.

Sub Test()
    Dim Bak As Long
    Dim BakGun As Integer
    Dim RakamVar As Boolean
    
    Application.ScreenUpdating = False
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 6 Step -1
        For BakGun = 4 To 35
            If IsNumeric(Cells(Bak, "AO").Text) Then
                RakamVar = True
                Exit For
            Else
                If IsNumeric(Cells(5, BakGun).Text) And IsNumeric(Cells(Bak, BakGun).Text) Then
                    RakamVar = True
                    Exit For
                End If
            End If
        Next
        If RakamVar = False Then
            Rows(Bak).Delete
        End If
        RakamVar = False
    Next

    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 6 Step -1
        Rows(Bak + 1).Insert
        Range("A" & Bak & ":A" & Bak + 1).Merge
        Range("B" & Bak & ":B" & Bak + 1).Merge
        Range("C" & Bak & ":C" & Bak + 1).Merge
  
        For BakGun = 4 To 35
            If IsNumeric(Cells(5, BakGun).Text) Then
                If IsNumeric(Cells(Bak, BakGun).Text) And Not IsEmpty(Cells(Bak, BakGun).Text) Then
                    Cells(Bak + 1, BakGun) = Cells(Bak, BakGun)
                    Cells(Bak, BakGun) = "x"
                ElseIf Not IsEmpty(Cells(Bak, BakGun)) Then
                    Cells(Bak, BakGun) = ""
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

 

[isakaratastan]

Yeni kodlar.

Sub Test()
    Dim Bak As Long
    Dim BakGun As Integer
    Dim RakamVar As Boolean
   
    Application.ScreenUpdating = False
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 6 Step -1
        For BakGun = 4 To 35
            If IsNumeric(Cells(Bak, "AO").Text) Then
                RakamVar = True
                Exit For
            Else
                If IsNumeric(Cells(5, BakGun).Text) And IsNumeric(Cells(Bak, BakGun).Text) Then
                    RakamVar = True
                    Exit For
                End If
            End If
        Next
        If RakamVar = False Then
            Rows(Bak).Delete
        End If
        RakamVar = False
    Next

    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 6 Step -1
        Rows(Bak + 1).Insert
        Range("A" & Bak & ":A" & Bak + 1).Merge
        Range("B" & Bak & ":B" & Bak + 1).Merge
        Range("C" & Bak & ":C" & Bak + 1).Merge
 
        For BakGun = 4 To 35
            If IsNumeric(Cells(5, BakGun).Text) Then
                If IsNumeric(Cells(Bak, BakGun).Text) And Not IsEmpty(Cells(Bak, BakGun).Text) Then
                    Cells(Bak + 1, BakGun) = Cells(Bak, BakGun)
                    Cells(Bak, BakGun) = "x"
                ElseIf Not IsEmpty(Cells(Bak, BakGun)) Then
                    Cells(Bak, BakGun) = ""
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

Teşekkür ederim elinize sağlık

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.