hucre ıcındekı verılerı altalta getırmek

[kakara]

Merhaba ustadlarım sızlerden rıcam eklı dosyada tek hucre ıcınde olan bedenlerı alt alta gelıcek sekılde parçalamak sızlerle paylastıgım dosyada daha detaylı anlatmaya calıstım ılgınız ıcın sımdıden tesekkur ederım

 

[kakara]

sorun devam etmektedır

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Separate_Bodies()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim My_Data As Variant, X As Long
    Dim Bodies As Variant, Bodie As Variant
    Dim My_Check As Boolean, Say As Long
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    S2.Range("A:B").ClearContents
    
    My_Data = S1.Range("A2:B" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
    
    ReDim My_List(1 To S1.Rows.Count, 1 To 2)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 1) <> "" Then
            Bodies = My_Data(X, 2)
            If IsNumeric(Left(Bodies, 1)) And _
                InStr(1, Bodies, "S") = 0 And _
                InStr(1, Bodies, "M") = 0 And _
                InStr(1, Bodies, "L") = 0 And _
                InStr(1, Bodies, "X") = 0 Then
                For Each Bodie In Split(Bodies, " ")
                    If Bodie <> "-" And Bodie <> "" Then
                        Say = Say + 1
                        My_List(Say, 1) = My_Data(X, 1)
                        My_List(Say, 2) = "'" & Bodie
                        My_Check = True
                    End If
                Next
                If My_Check = True Then
                    Say = Say + 1
                    My_List(Say, 1) = Empty
                    My_List(Say, 2) = Empty
                    My_Check = False
                End If
            Else
                For Each Bodie In Split(Bodies, "-")
                    Say = Say + 1
                    My_List(Say, 1) = My_Data(X, 1)
                    My_List(Say, 2) = Bodie
                    My_Check = True
                Next
                If My_Check = True Then
                    Say = Say + 1
                    My_List(Say, 1) = Empty
                    My_List(Say, 2) = Empty
                    My_Check = False
                End If
            End If
        End If
    Next
    
    S2.Range("A1:B1") = Array("SNK KOD", "BEDEN")
    S2.Range("A2").Resize(Say, 2) = My_List
    S2.Columns("A:B").AutoFit
    S2.Select
    
    Erase My_Data
    Erase My_List
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "Bedenler ayrıştırılmıştır.", vbInformation
End Sub

 

[kakara]

@Korhan Ayhan ustadım verdıgınız kod calısıyor sadece yaş olan bedenlerde 9-10 dıye atması gerekırken 9 alttakı hucreyede 10 olarak atıyor ve her snk kodundan sonra bır bosluk bırakma sansımız varmı yanı snk 309 dort beden alt alta gelıcek bır bosluk snk310 dıye devam edıcek. ilginiz için çok tesekkur ederım.

 

[Korhan Ayhan]

Arada beden kısımları boş olan hücreler var. Bunlar listelenecek mi?

 

[kakara]

@Korhan Ayhan ustadım eger beden kısmı bos ıse onlar lıstelenmesın

 

[Korhan Ayhan]

Önerdiğim kodu revize ettim. Tekrar deneyiniz.

 

[kakara]

@Korhan Ayhan ustadım cok tesekkurler kod calısıyor