YANINDAKİ SAYI ADEDİ KADAR ÇOĞALTMA

[gumrukdisticaret]

5002	6		500250025002500250025002
630267	33		630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267630267

MERHABA ARKADAŞLAR SOLDAKİ RAKAMLARI YANINDA Kİ ADETLERİ KADAR ALT ALTA ÇOĞLATMAK İSTİYORUM.
=YİNELE(A1;B1) OLARAK YANINDAKİ ADET KADAR ÇOĞLATTIM FAKAT BUNLARI YAN YANA DEĞİL AYRI AYRI SÜTUNLARA GETİRMEK İSTİYORUM

 

[Necdet]

Merhaba,
Makrolu çözüm isterseniz, deneyiniz.

kod A ve B sütununu Alır , E sütununda alt alta listeler.

Public Sub cogalt()

Dim arr As Variant
Dim i   As Long
Dim b   As Long
Dim s   As Long

Application.ScreenUpdating = False
arr = Range("A1").CurrentRegion
Range("E:E").ClearContents

For i = LBound(arr, 1) To UBound(arr, 1)
    b = Cells(Rows.Count, "E").End(3).Row + 1
    Range("E" & b & ":E" & b + arr(i, 2) - 1) = arr(i, 1)
Next i

Application.ScreenUpdating = True

End Sub

 

[gumrukdisticaret]

HOCAM HATA VERDİ.
ALT+F11
INSERT
MODULE
F5


YAPIYORUM OLMUYOR

A1

5002

B1

6

C1
500250025002500250025002

Merhaba,
Makrolu çözüm isterseniz, deneyiniz.

kod A ve B sütununu Alır , E sütununda alt alta listeler.

Public Sub cogalt()

Dim arr As Variant
Dim i   As Long
Dim b   As Long
Dim s   As Long

Application.ScreenUpdating = False
arr = Range("A1").CurrentRegion
Range("E:E").ClearContents

For i = LBound(arr, 1) To UBound(arr, 1)
    b = Cells(Rows.Count, "E").End(3).Row + 1
    Range("E" & b & ":E" & b + arr(i, 2) - 1) = arr(i, 1)
Next i

Application.ScreenUpdating = True

End Sub

 

[Necdet]

Verdiğim kodda sizin önerdiğiniz veri yapısı var. sadece A ve B sütunu dolu olmalı, Birinci satırdan başlamalı veri. Ayrıca B sütunundaki Adet sayısını da kontrol etmedim, boş olmaması gerek.

 

[Ali]

Sub ListeyiOlustur()

    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim i As Long, j As Long
    Dim hedefSatir As Long
    
    Set ws = ActiveSheet
    
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ws.Range("E:E").ClearContents
    
    hedefSatir = 1
    
    For i = 1 To sonSatir
        If ws.Cells(i, "A").Value <> "" And IsNumeric(ws.Cells(i, "B").Value) Then
            For j = 1 To CLng(ws.Cells(i, "B").Value)
                ws.Cells(hedefSatir, "E").Value = ws.Cells(i, "A").Value
                hedefSatir = hedefSatir + 1
            Next j
        End If
    Next i

End Sub

 

[Ali]

Office 365 için

=FİLTRE(METİNBÖL(METİNBİRLEŞTİR("|";;YİNELE($A$1:$A$4&"|";$B$1:$B$4));;"|");METİNBÖL(METİNBİRLEŞTİR("|";;YİNELE($A$1:$A$4&"|";$B$1:$B$4));;"|")<>"")

Eski versiyonlar için

=EĞER(SATIRSAY(E$1:E1)>TOPLA($B$1:$B$4);"";İNDİS($A$1:$A$4;1+TOPLA.ÇARPIM(--(SATIRSAY(E$1:E1)>DÇARP(--(SATIR($B$1:$B$4)>=DEVRİK_DÖNÜŞÜM(SATIR($B$1:$B$4)));$B$1:$B$4)))))

 

[alicimri]

Office 365 için, alternatif, veriler A ve B sütunlarında, formül C1 hücresine

=DEVRİK_DÖNÜŞÜM(METİNBÖL(KIRP(METİNBİRLEŞTİR(" ";DOĞRU;YİNELE(" "&A:A;B:B)));" "))