Bir hücredeki metni diğer bir hücreye değişken sayıda yazdırma

[enginakbulut]

A sütunu / B sütunu
TA3 / 4
TA5 / 3
TA8-2 / 5
olduğunu varsayalım istediğim çıktı ise
E sütununa yazılacak şekilde
TA3 (1)
TA3 (2)
TA3 (3)
TA3 (4)
TA5 (1)
TA5 (2)
TA5 (3)
TA8-2 (1)
TA8-2 (2)
TA8-2 (3)
TA8-2 (4)
TA8-2 (5)
şeklinde.

for döngüsünün bitiş değerini B sütununa bağlayamadığım için bir türlü yapamadım yardımlarınız için şimdiden teşekkürler.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Yaz()

    Dim i As Long
    Dim j As Long
    Dim a As Integer

    Range("E:E").ClearContents
    Application.ScreenUpdating = False
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        a = 0
        Do
            a = a + 1
            j = j + 1
            Cells(j, "E") = Cells(i, "A") & " (" & a & ")"
        Loop While a < Cells(i, "B")
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem Tamamdır....."
    
End Sub

 

[enginakbulut]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Yaz()

    Dim i As Long
    Dim j As Long
    Dim a As Integer

    Range("E:E").ClearContents
    Application.ScreenUpdating = False
   
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        a = 0
        Do
            a = a + 1
            j = j + 1
            Cells(j, "E") = Cells(i, "A") & " (" & a & ")"
        Loop While a < Cells(i, "B")
    Next i
   
    Application.ScreenUpdating = True
   
    MsgBox "İşlem Tamamdır....."
   
End Sub

istediğim tam olarak buydu çok teşekkür ederim

 

[Necdet]

Güle güle kullanınız.

 

[Necdet]

Merhaba,

Bu da alternatif kod olsun.

Sub Yaz()

    Dim i   As Long, _
        j   As Long, _
        k   As Integer, _
        d   As Variant
        
    Application.ScreenUpdating = False
    Range("E:E").ClearContents
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
    
        ReDim d(1 To Cells(i, "B"))
        For k = 1 To Cells(i, "B")
            d(k) = Cells(i, "A") & " (" & k & ")"
        Next k
        
        Range("E" & Cells(Rows.Count, "E").End(3).Row + 1).Resize(Cells(i, "B"), 1) = Application.WorksheetFunction.Transpose(d)
        
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır...."
    
End Sub

 

[enginakbulut]

Merhaba,

Bu da alternatif kod olsun.

Sub Yaz()

    Dim i   As Long, _
        j   As Long, _
        k   As Integer, _
        d   As Variant
       
    Application.ScreenUpdating = False
    Range("E:E").ClearContents
   
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
   
        ReDim d(1 To Cells(i, "B"))
        For k = 1 To Cells(i, "B")
            d(k) = Cells(i, "A") & " (" & k & ")"
        Next k
       
        Range("E" & Cells(Rows.Count, "E").End(3).Row + 1).Resize(Cells(i, "B"), 1) = Application.WorksheetFunction.Transpose(d)
       
    Next i
   
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamdır...."
   
End Sub

Tekrar teşekkürler