Boş hücreleri yok sayarak tek yönlü devrik dönüşüm yapmak

[tytoontytoon]

Merhaba
Konuyu Macro - VBA başlığında açtım ama belki formül ile de çözülebilir...çok yeni olduğum için emin olamadım. Kısaca sorunum, ekli dosya yer alan TABLO sayfasına koyacağım veri ile çıktı sayfasındaki veriyi elde etmek... Basit bir devrik dönüşüm ama boş hücreleri nasıl aktaracağımı çözemedim. Tabi gerçek datam hem sağ, hem de aşağı doğru bundan çok daha fazla... Nasıl devam ettireceğimi de belirtirseniz sevinirim...şimdiden çok teşekkür ederim...

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp dener misiniz?

Sub Aktar()

    Dim ShT As Worksheet, _
        ShC As Worksheet, _
        i   As Long, _
        j   As Integer, _
        Sat As Long, _
        Kol As Integer, _
        Drm As Boolean
        
    Set ShT = Sheets("TABLO")
    Set ShC = Sheets("ÇIKTI")
    
    Sat = 1
    Kol = ShT.Cells(1, Columns.Count).End(1).Column
    
    Application.ScreenUpdating = False
    
    ShC.Range("A2:C" & Rows.Count).ClearContents
    
    For i = 2 To ShT.Cells(Rows.Count, "A").End(3).Row
    
        If Evaluate("=COUNTA(" & ShT.Name & "!" & Range(Cells(i, 3), Cells(i, 30)).Address & ")") > 0 Then
            
            For j = 3 To Kol
            
                If Not ShT.Cells(i, j) = "" Then
                    Sat = Sat + 1
                    ShC.Cells(Sat, "A") = ShT.Cells(i, "A")
                    ShC.Cells(Sat, "B") = ShT.Cells(i, "B")
                    ShC.Cells(Sat, "C") = ShT.Cells(i, j)
                    ShC.Cells(Sat, "D") = ShT.Cells(1, j)
                End If
                
            Next j
        End If
        
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem Tamamdır......"
    
End Sub

 

[ÖmerFaruk]

Sub ÇıktıListele()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim i As Integer, k As Integer, x As Integer
Set Sh1 = Worksheets("TABLO")
Set Sh2 = Worksheets("ÇIKTI")
x = 1
For i = 2 To Sh1.Range("A1").End(xlDown).Row
    For k = 3 To Sh1.Range("A1").End(xlToRight).Column
        If Sh1.Cells(i, k) <> "" Then
            x = x + 1
            Sh2.Range("A" & x) = Sh1.Range("A" & i)
            Sh2.Range("B" & x) = Sh1.Range("B" & i)
            Sh2.Range("C" & x) = Sh1.Cells(i, k)
            Sh2.Range("D" & x) = Sh1.Cells(1, k)
        End If
    Next k
Next i
End Sub

 

[tytoontytoon]

Çok Teşekkürler Necdet bey....Aynı data geldi... Ancak sağ taraf yeni sütun eklediğimde güncellemesi rağmen, alt tarafa yeni satır eklediğimde güncellemedi... benim bir hatam olmuş olabilir mi?

 

[tytoontytoon]

teşekkürler Next Level... hem satır hem sutün eklediğimde çalıştı... elinize sağlık

 

[Korhan Ayhan]

Alternatif;

Hız olarak avantaj sağlayabilir.

Option Explicit

Sub Aktar()
    Dim Zaman As Double, S1 As Worksheet, S2 As Worksheet, Veri As Variant
    Dim Son As Long, x As Long, Say As Long, Y As Integer, Satir As Long
    
    Zaman = Timer
    
    Set S1 = Sheets("TABLO")
    Set S2 = Sheets("ÇIKTI")
    
    S2.Range("A2:D" & S2.Rows.Count).Clear
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son <= 2 Then Son = 3
    
    Veri = S1.Range("A1").CurrentRegion.Value
    
    Satir = S1.Range("A1").CurrentRegion.Rows.Count * S1.Range("A1").CurrentRegion.Columns.Count
    
    ReDim Liste(1 To Satir, 1 To 4)
    
    For x = 2 To UBound(Veri, 1)
        If Veri(x, 1) <> "" Then
            For Y = 3 To UBound(Veri, 2)
                If Veri(x, Y) <> "" Then
                    Say = Say + 1
                    Liste(Say, 1) = CStr(Veri(x, 1))
                    Liste(Say, 2) = Veri(x, 2)
                    Liste(Say, 3) = Veri(x, Y)
                    Liste(Say, 4) = Veri(1, Y)
                End If
            Next
        End If
    Next
    
    If Say > 0 Then
        With S2.Range("A2").Resize(Say, 4)
            .Columns(1).NumberFormat = "@"
            .Value = Liste
            .Borders.LineStyle = 1
        End With
    
        MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "İşlem için uygun veri bulunamadı!", vbExclamation
    End If
End Sub

 

[Necdet]

Çok Teşekkürler Necdet bey....Aynı data geldi... Ancak sağ taraf yeni sütun eklediğimde güncellemesi rağmen, alt tarafa yeni satır eklediğimde güncellemedi... benim bir hatam olmuş olabilir mi?

Merhaba,

Yeni sütun eklendiğinde kodlarda zaten bu mantık var.

Kol = ShT.Cells(1, Columns.Count).End(1).Column

yukarıdaki kod ile tablo sayfasında en son sütun bulunup, buna göre verilere bakılıyor.
Eğer siz Tablo sayfasında başlık satırına sütun değeri girmezseniz, sonraki satırlarda girdiğiniz verilere doğal olarak bakmaz.

40 yıllık yazılımcı sanırım bunları düşünür değil mi?