Kodlarda Düzeltme

[hakki83]

Merhaba iyi günler,
İki adet örnekte birbirine benzeyen iki adet kod vardır.

Fakat K sütununa bu kodlar isimleri de numaraları da yanlış döküyor.
İsimin altına kendine ait numaralar gelmeli.

İki dosyadan herhangi birini düzeltebilir miyiz, teşekkürler.

(İsimler numaralar uydurmadır)

 

[Korhan Ayhan]

Merhaba,

Option Explicit

Sub Listele()
    Dim WS As Worksheet, X As Long, Y As Integer, Last_Row As Long
    
    Application.ScreenUpdating = False
    
    Set WS = Sheets("Sheet1")
    
    WS.Columns("K").Clear
    WS.Columns("K").NumberFormat = "@"
    
    Last_Row = 2
    
    For X = 2 To WS.Cells(WS.Rows.Count, 1).End(3).Row
        WS.Range("K" & Last_Row).Resize(WS.Cells(X, "K").End(1).Column) = _
        Application.Transpose(WS.Range("A" & X).Resize(, WS.Cells(X, "K").End(1).Column))
        Last_Row = WS.Cells(WS.Rows.Count, "K").End(3).Row + 1
    Next

    Set WS = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Bu da dizi yöntemiyle alternatif olsun.. Daha hızlı sonuç verecektir.

Option Explicit

Sub Listele()
    Dim WS As Worksheet, My_Data As Variant, No As Long
    Dim My_List() As Variant, X As Long, Y As Integer
    
    Set WS = Sheets("Sheet1")
    
    WS.Columns("K").ClearContents
    WS.Columns("K").NumberFormat = "@"
    
    My_Data = WS.Range("A2:E" & WS.Cells(WS.Rows.Count, 1).End(3).Row).Value
    
    ReDim My_List(1 To WS.Rows.Count, 1 To 1)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        No = No + 1
        My_List(No, 1) = My_Data(X, 1)
        For Y = 2 To UBound(My_Data, 2)
            If My_Data(X, Y) <> "" Then
                No = No + 1
                My_List(No, 1) = My_Data(X, Y)
            End If
        Next
    Next

    WS.Range("K2").Resize(No) = My_List

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[hakki83]

Emeğinize sağlık Korhan hocamız.