Copy and paste Multiple times based on cell value

[thomsonreuters]

Hi
I want to copy and paste range of cells multiple times based on specific value mention in the cells.
The problem is want to paste range of cells difference time...pls see below, it will give more clarity...its very urgent...pls pls help me someone...column A copy range and colum B no.of time copy and past....Column C is what I want to do..
Colum A Column B Column C
ABCD 2 ABCD
FGHI 1 FGHI
KLMN 3 KLMN
PQRS 3 PQRS
ABCD
KLMN
PQRS
KLMN
PQRS
Copy and paste should be range of cells, not like same cells pasted multiple time again and again continuously....

Pls help on this

Thanks
JP

 

[Trebor76]

Try this:

'https://www.mrexcel.com/board/threads/copy-and-paste-multiple-times-based-on-cell-value.1133775
Option Explicit
Sub Macro1()

    Dim lngMyRow As Long
    Dim lngPasteRow As Long
    
    Application.ScreenUpdating = False
    
    For lngMyRow = 2 To Cells(Rows.Count, "A").End(xlUp).Row 'Starts from Row 2. Change to suit.
        lngPasteRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
        Cells(lngPasteRow, "C").Resize(Cells(lngMyRow, "B")).Value = Cells(lngMyRow, "A")
    Next lngMyRow

    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[thomsonreuters]

Try this:

'https://www.mrexcel.com/board/threads/copy-and-paste-multiple-times-based-on-cell-value.1133775
Option Explicit
Sub Macro1()

    Dim lngMyRow As Long
    Dim lngPasteRow As Long
   
    Application.ScreenUpdating = False
   
    For lngMyRow = 2 To Cells(Rows.Count, "A").End(xlUp).Row 'Starts from Row 2. Change to suit.
        lngPasteRow = Cells(Rows.Count, "C").End(xlUp).Row + 1
        Cells(lngPasteRow, "C").Resize(Cells(lngMyRow, "B")).Value = Cells(lngMyRow, "A")
    Next lngMyRow

    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Thanks much Robert, but this is not what i am required

i want like below

From your code	My Requirement
ABCD	ABCD
ABCD	FGHI
FGHI	KLMN
KLMN	PQRS
KLMN	ABCD
KLMN	KLMN
PQRS	PQRS
PQRS	KLMN
PQRS	PQRS

same text should not be repeat continuously.....hope you understand... advance thanks for your help on this... thanks JP

 

[Trebor76]

Try this:

Option Explicit
Sub Macro1()

    Dim i As Long
    Dim lngMyRow As Long, lngLastRow As Long, lngPasteRow As Long
    
    'The code assumes the following:
    '1. Numbers for output text are in Col. B
    '2. Text to be outputted are in Col. C
    '3. Output will be the next avaliable row in Col. A
    
    Application.ScreenUpdating = False
    
    lngLastRow = Range("B:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For i = 1 To Evaluate("MAX(B:B)")
        For lngMyRow = 2 To lngLastRow
            If Range("B" & lngMyRow).Value >= i Then
                lngPasteRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
                Range("A" & lngPasteRow).Value = Range("C" & lngMyRow).Value
            End If
        Next lngMyRow
    Next i
    
    Application.ScreenUpdating = True

End Sub

 

[thomsonreuters]

Try this:

Option Explicit
Sub Macro1()

    Dim i As Long
    Dim lngMyRow As Long, lngLastRow As Long, lngPasteRow As Long
   
    'The code assumes the following:
    '1. Numbers for output text are in Col. B
    '2. Text to be outputted are in Col. C
    '3. Output will be the next avaliable row in Col. A
   
    Application.ScreenUpdating = False
   
    lngLastRow = Range("B:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For i = 1 To Evaluate("MAX(B:B)")
        For lngMyRow = 2 To lngLastRow
            If Range("B" & lngMyRow).Value >= i Then
                lngPasteRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
                Range("A" & lngPasteRow).Value = Range("C" & lngMyRow).Value
            End If
        Next lngMyRow
    Next i
   
    Application.ScreenUpdating = True

End Sub

WooooooW Robert....it's working fine. Thank u so much...

Will post again if i need any help

thanks
JP

 

[Trebor76]

You're welcome. I'm glad we got it sorted.