Soru Dolu Sütunları Tek Sütunda Alt Alta Yazma

[leonadies]

Üstadlar Merhaba;

Şöyle bir makroya ihitiyacım oldu. Hepsi "Veriler" sekmesinde olmak üzere istediğim sütunların sadece dolu olan hücrelerini "AD" sütununda alt alta getirmek istiyorum.
Sütunlar şimdilik belli değil. İhtiyacım olanı makrodan kendim belirtmek istiyorum.

 

[Ömer]

Merhaba,

sut değerinden aranacak sütunları belirleyebilirsiniz.

Sub dolu_sutun()
    
    Dim sut(), s As Integer, i As Integer, son_ad As Long, sat As Long
    
    Application.ScreenUpdating = False
    Sheets("Veriler").Select
    Range("AD2:AD" & Rows.Count).ClearContents
    
    sut = Array("B", "E", "G") 'aranacak sütunlar
    
    s = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    For i = 0 To UBound(sut)
        If sut(i) <> "AD" Then
            ActiveSheet.AutoFilterMode = False
            son_ad = Cells(Rows.Count, "AD").End(xlUp).Row + 1
            sat = Cells(Rows.Count, sut(i)).End(xlUp).Row
            Range(Cells(1, sut(i)), Cells(sat, sut(i))).AutoFilter Field:=1, Criteria1:="<>"
            Range(Cells(2, sut(i)), Cells(sat, sut(i))).SpecialCells(xlCellTypeVisible).Copy Cells(son_ad, "AD")
        End If
    Next i
    
    ActiveSheet.AutoFilterMode = False
    
End Sub

 

[leonadies]

Teşekkürler @Ömer Hocam

 

[muratboz06]

Ekteki çalışmayı inceleyebilirsiniz.

Kitap1.xlsm dosyasını indir - download

Kitap1.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[leonadies]

@Ömer hocam bir kaç sütünda Damga (10) içeren bilgiler mevcut sanırım bundan kaynaklı bir hata oluşuyor. Resmi ekledim.

 

[Ömer]

Küçük bir örnek dosya ekler misiniz.
AD deki satır sayısı kopyalanan değerlerden az kalırsa ne olması gerekiyor. Bu şekilde bir durum da olabilir mi?

 

[leonadies]

@Ömer hocam sebebi tespit ettim. Sütunlarda;
ilk satır üst bilgi
2. satır dolu
3. satır boş (muhtemelen) bundan kaynaklanıyor. 3.satırı doldurunca hatasız yapıyor işlemi

 

[Korhan Ayhan]

Alternatif;

Option Explicit

Sub Sutunlari_Birlestir()
    Dim Sutun As Variant, Veri As Variant, Sutun_Kontrol As Object, Son As Long
    Dim X As Long, Y As Long, Say As Long, Zaman As Double
    
    Sutun = Application.InputBox("İşlem yapmak istediğiniz sütunları yazınız." & Chr(10) & _
            "Aralarına virgül ekleyerek sütun harflerini yazınız." & Chr(10) & Chr(10) & _
            "Örnek ; A,B,C,D,E,F", "İşlem Yapılacak Sütun Bilgileri")
    
    If Sutun = False Or Sutun = "" Then
        MsgBox "İşleme devam edebilmeniz için sütun bilgilerini girmelisiniz!", vbCritical
        Exit Sub
    End If
    
    Zaman = Timer
    
    Set Sutun_Kontrol = CreateObject("Scripting.Dictionary")
    
    Range("AD:AD").Clear
    Range("AD1") = "TÜM VERİ"
    Range("AD1").Font.Bold = True
    Range("AD1").HorizontalAlignment = xlCenter
    
    ReDim Liste(1 To Rows.Count, 1 To 1)
    
    If InStr(1, Sutun, ",") = 0 Then
        Sutun = Sutun & ","
    End If
    
    Sutun = Split(Sutun, ",")
    
    For X = LBound(Sutun) To UBound(Sutun)
        If Sutun(X) <> "" Then
            On Error Resume Next
            If IsError(Cells(1, Sutun(X)).Column) Then GoTo 10
            On Error GoTo 0
            If Not Sutun_Kontrol.Exists(Sutun(X)) Then
                Sutun_Kontrol.Add Sutun(X), Nothing
                Son = Cells(Rows.Count, Sutun(X)).End(3).Row
                If Son = 1 Then Son = Son + 1
                Veri = Cells(1, Sutun(X)).Resize(Son).Value2
                For Y = LBound(Veri) To UBound(Veri)
                    If Veri(Y, 1) <> "" Then
                        Say = Say + 1
                        Liste(Say, 1) = Veri(Y, 1)
                    End If
                Next
            End If
        End If
10  Next

    Set Sutun_Kontrol = Nothing

    If Say = 0 Then
        MsgBox "Birleştirilecek veri bulunamadı!", vbExclamation
    Else
        Range("AD2").Resize(Say, 1) = Liste
        Range("AD:AD").Columns.AutoFit
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    End If
End Sub

 

[leonadies]

@Korhan Ayhan Hocam yine sütunları makrodan ayarlayabilsem (yani soru sorulmadan) çok güzel olur.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Sutunlari_Birlestir()
    Dim S1 As Worksheet, Sutun As Variant, Veri As Variant, Son As Long
    Dim X As Long, Y As Long, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Veriler")
    
    With S1
        .Range("AD:AD").Clear
        .Range("AD1") = "TÜM VERİ"
        .Range("AD1").Font.Bold = True
        .Range("AD1").HorizontalAlignment = xlCenter
    
        ReDim Liste(1 To Rows.Count, 1 To 1)
        
        Sutun = Array("A", "B", "C", "D", "E")
        
        For X = LBound(Sutun) To UBound(Sutun)
            If Sutun(X) <> "" Then
                Son = .Cells(.Rows.Count, Sutun(X)).End(3).Row
                If Son = 1 Then Son = Son + 1
                Veri = .Cells(1, Sutun(X)).Resize(Son).Value2
                For Y = LBound(Veri) To UBound(Veri)
                    If Veri(Y, 1) <> "" Then
                        Say = Say + 1
                        Liste(Say, 1) = Veri(Y, 1)
                    End If
                Next
            End If
        Next
    
        If Say = 0 Then
            MsgBox "Birleştirilecek veri bulunamadı!", vbExclamation
        Else
            .Range("AD2").Resize(Say, 1) = Liste
            .Range("AD:AD").Columns.AutoFit
            MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
                   "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
        End If
    End With
    
    Set S1 = Nothing
End Sub

 

[canigdeli]

Merhaba benzer bir excel çalışmasında yardımınıza ihtiyacım var eğer yardımcı olabilirseniz çok sevinirim. Bir araştırma datasındaki verileri tek sütun altında sıralamam gerekiyor ancak yukarıdaki örneklerde excelleri göremediğim için benim excelim hangi verileri makroya yerleştireceğimi çözemedim.
Destek olursanız manuel olarak sıraladığım sütunları sizin sayenizde kısa sürede halledip esas konuma başlayabileceğim.
Şimdiden teşekkürler

(Excel çalışmamı görmeniz için nasıl yükleyebiliyorum?)

 

[YUSUF44]

Merhaba benzer bir excel çalışmasında yardımınıza ihtiyacım var eğer yardımcı olabilirseniz çok sevinirim. Bir araştırma datasındaki verileri tek sütun altında sıralamam gerekiyor ancak yukarıdaki örneklerde excelleri göremediğim için benim excelim hangi verileri makroya yerleştireceğimi çözemedim.
Destek olursanız manuel olarak sıraladığım sütunları sizin sayenizde kısa sürede halledip esas konuma başlayabileceğim.
Şimdiden teşekkürler

(Excel çalışmamı görmeniz için nasıl yükleyebiliyorum?)

Mümkünse yeni konu açınız. Dosyayı imzamda belirttiğim gibi paylaşabilirsiniz.

 

[canigdeli]

Mümkünse yeni konu açınız. Dosyayı imzamda belirttiğim gibi paylaşabilirsiniz.

Yusuf Bey hızlı dönüşünüz için çok teşekkür ederim.
Yeni konu olarak açtım.
Desteğiniz son derece önemlidir.