Vba copy from sheet1 and paste to sheet2

[Krissariet]

Hi! I need help with a vba. I need to copy a selected row only if i selected it from sheet 1 and paste it to sheet 2 in the same location for a number of times that is in sheet 1 in J cloumn.
For example I need to copy data from sheet1 to sheet2 from A2 to I2 the number of times that is in J2 and then select data to A3 to I3 the number of times that is in I3 but just when I selected it. Hope you can help me and please forgive me for my english. Thank you!

 

[Krissariet]

 

[Alex Blakenburg]

See if this works for you.

Sub CopyLines()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcLRow As Long, destLRow As Long
    Dim srcArr As Variant, destArr() As Variant
    Dim NoOfLines As Long, destRow As Long
    Dim iRow As Long, iCol As Long, iLines As Long
    
    Set srcSht = Worksheets("Sheet1")
    Set destSht = Worksheets("Sheet2")
    
    srcLRow = srcSht.Range("A" & Rows.Count).End(xlUp).Row
    Set srcRng = srcSht.Range("A2:J" & srcLRow)
    srcArr = srcRng
    NoOfLines = Application.Sum(srcRng.Columns(10))
    ReDim destArr(1 To NoOfLines, 1 To UBound(srcArr, 2))
    
    For iRow = 1 To UBound(srcArr)
        For iLines = 1 To srcArr(iRow, 10)
            destRow = destRow + 1
            For iCol = 1 To UBound(srcArr, 2)
                destArr(destRow, iCol) = srcArr(iRow, iCol)
            Next iCol
        Next iLines
    Next iRow
    
    destSht.Range("A2").Resize(UBound(destArr, 1), UBound(destArr, 2)).Value = destArr

End Sub

 

[Krissariet]

See if this works for you.

Sub CopyLines()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcLRow As Long, destLRow As Long
    Dim srcArr As Variant, destArr() As Variant
    Dim NoOfLines As Long, destRow As Long
    Dim iRow As Long, iCol As Long, iLines As Long
   
    Set srcSht = Worksheets("Sheet1")
    Set destSht = Worksheets("Sheet2")
   
    srcLRow = srcSht.Range("A" & Rows.Count).End(xlUp).Row
    Set srcRng = srcSht.Range("A2:J" & srcLRow)
    srcArr = srcRng
    NoOfLines = Application.Sum(srcRng.Columns(10))
    ReDim destArr(1 To NoOfLines, 1 To UBound(srcArr, 2))
   
    For iRow = 1 To UBound(srcArr)
        For iLines = 1 To srcArr(iRow, 10)
            destRow = destRow + 1
            For iCol = 1 To UBound(srcArr, 2)
                destArr(destRow, iCol) = srcArr(iRow, iCol)
            Next iCol
        Next iLines
    Next iRow
   
    destSht.Range("A2").Resize(UBound(destArr, 1), UBound(destArr, 2)).Value = destArr

End Sub

Thank you very much!!! It is very helpful but not quite what I need. I need to copy to the sheet2 only when I select the row the number of times that are in J in that row, not the entire rows. For exemple if I need the data of the first row i have to select that data and it hase to be copied the number of times that are in the J1
And then if I need the data from the 5th row I have to select that data and it hase to be copied the number of times that are in J5.

 

[Alex Blakenburg]

So are you only selecting 1 row and are you still copying all the columns A:I ?
Are you expecting an Input box to make the selection for are you selecting it and then hitting a button that says copy selected ?

 

[Krissariet]

So are you only selecting 1 row and are you still copying all the columns A:I ?
Are you expecting an Input box to make the selection for are you selecting it and then hitting a button that says copy selected ?

Yes I only select 1 row from A:I
I need to select it and thet hit a button that says copy selected

 

[Alex Blakenburg]

OK, try this.
I just modified what I already had:

Sub CopyLinesSelected()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcLRow As Long, destLRow As Long
    Dim srcArr As Variant, destArr() As Variant
    Dim NoOfLines As Long, destRow As Long
    Dim iRow As Long, iCol As Long, iLines As Long
    
    Set srcSht = Worksheets("Sheet1")
    Set destSht = Worksheets("Sheet2")
    
    srcLRow = srcSht.Range("A" & Rows.Count).End(xlUp).Row
    Set srcRng = srcSht.Range("A2:J2").Offset(Selection.Row - 2)
    srcArr = srcRng
    NoOfLines = Application.Sum(srcRng.Columns(10))
    ReDim destArr(1 To NoOfLines, 1 To UBound(srcArr, 2))
    
    For iRow = 1 To UBound(srcArr)
        For iLines = 1 To srcArr(iRow, 10)
            destRow = destRow + 1
            For iCol = 1 To UBound(srcArr, 2)
                destArr(destRow, iCol) = srcArr(iRow, iCol)
            Next iCol
        Next iLines
    Next iRow
    
    destSht.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(destArr, 1), UBound(destArr, 2) - 1).Value = destArr

End Sub

 

[Krissariet]

OK, try this.
I just modified what I already had:

Sub CopyLinesSelected()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcLRow As Long, destLRow As Long
    Dim srcArr As Variant, destArr() As Variant
    Dim NoOfLines As Long, destRow As Long
    Dim iRow As Long, iCol As Long, iLines As Long
   
    Set srcSht = Worksheets("Sheet1")
    Set destSht = Worksheets("Sheet2")
   
    srcLRow = srcSht.Range("A" & Rows.Count).End(xlUp).Row
    Set srcRng = srcSht.Range("A2:J2").Offset(Selection.Row - 2)
    srcArr = srcRng
    NoOfLines = Application.Sum(srcRng.Columns(10))
    ReDim destArr(1 To NoOfLines, 1 To UBound(srcArr, 2))
   
    For iRow = 1 To UBound(srcArr)
        For iLines = 1 To srcArr(iRow, 10)
            destRow = destRow + 1
            For iCol = 1 To UBound(srcArr, 2)
                destArr(destRow, iCol) = srcArr(iRow, iCol)
            Next iCol
        Next iLines
    Next iRow
   
    destSht.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(destArr, 1), UBound(destArr, 2) - 1).Value = destArr

End Sub

It is exactly what I neet but I forgot to a detail some of the cells have custom format and values so it has to be copied whit the values and source firrmatting

 

[Alex Blakenburg]

Ok that requires a different approach.

Sub CopyLinesSelectedWithFormatti()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcLRow As Long
    Dim NoOfLines As Long
    
    Application.ScreenUpdating = False
    
    Set srcSht = Worksheets("Sheet1")
    Set destSht = Worksheets("Sheet2")
    Set destRng = destSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
    
    srcLRow = srcSht.Range("A" & Rows.Count).End(xlUp).Row
    Set srcRng = srcSht.Range("A1:I" & srcLRow).Rows(Selection.Row)
    NoOfLines = srcRng.Columns(10)
    
    srcRng.Copy
        destRng.Resize(NoOfLines, srcRng.Columns.Count).PasteSpecial Paste:=xlPasteValues
        destRng.Resize(NoOfLines, srcRng.Columns.Count).PasteSpecial Paste:=xlPasteFormats
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[Krissariet]

Ok that requires a different approach.

Sub CopyLinesSelectedWithFormatti()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcLRow As Long
    Dim NoOfLines As Long
   
    Application.ScreenUpdating = False
   
    Set srcSht = Worksheets("Sheet1")
    Set destSht = Worksheets("Sheet2")
    Set destRng = destSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
   
    srcLRow = srcSht.Range("A" & Rows.Count).End(xlUp).Row
    Set srcRng = srcSht.Range("A1:I" & srcLRow).Rows(Selection.Row)
    NoOfLines = srcRng.Columns(10)
   
    srcRng.Copy
        destRng.Resize(NoOfLines, srcRng.Columns.Count).PasteSpecial Paste:=xlPasteValues
        destRng.Resize(NoOfLines, srcRng.Columns.Count).PasteSpecial Paste:=xlPasteFormats
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Thank you very much!!! It's perfect!!!