VBA code to copy and paste rows twice from one workbook to another

Question

I´m struggling to create a VBA code that does the following:

Copy and paste values from source data set:

into a new workbook in a format shown here:

VBA below works fine to paste values from columns C & D in alternate rows into the new workbook:

Sub rangeToColumn()

Dim rng As Range
Dim i 'index of cells
Dim f

Set rng = Workbooks("Excel1").Worksheets("SourceSheet").Range("C3:D6")
i = 0
For Each f In rng
    i = i + 1
    Workbooks("Excel2").Worksheets("TargetSheet").Cells(i, 1).Value = f.Value
Next f

End Sub

However I just can´t find out how to proceed with the rest. Tried multiple things but none of them worked. I basically need B3:B6 values from source to have twice in column C in target workbook and same for E3:E6 with only difference that each line below should be the opposite value.

Any help is much appreciated. Thanks.

Thomas.

Answer 1

try this code which you can customize to fit your needs.

If you have more columns just copy and paste at the end the code bellow "Copy first column"

Sub rangeToColumn()

    ' Define objects
    Dim sourceRange As Range
    Dim sourceCell As Range
    Dim targetCell As Range

    ' Define variables
    Dim sourceWBName As String ' WB = Workbook name
    Dim targetWBName As String

    Dim sourceWSName As String ' WS = Worksheet name
    Dim targetWSName As String

    Dim sourceRangeAddress As String
    Dim targetInitCellAddress As String ' Cell's address

    Dim counter As Integer ' Change for long instead of integer if more than 32000 values

    ' Initialize variables
    sourceWBName = "Book1"
    targetWBName = "Book2"

    sourceWSName = "SourceSheet"
    targetWSName = "TargetSheet"



    ' Copy first column
    sourceRangeAddress = "C2:C5"
    targetInitCellAddress = "A1" ' Address of first cell where to begin copy the values

    Set sourceRange = Workbooks(sourceWBName).Worksheets(sourceWSName).Range(sourceRangeAddress)
    Set targetCell = Workbooks(targetWBName).Worksheets(targetWSName).Range(targetInitCellAddress)

    counter = 0

    For Each sourceCell In sourceRange

        targetCell.Offset(counter, 0).Value = sourceCell.Value

        counter = counter + 1

    Next sourceCell


    ' Copy second column
    sourceRangeAddress = "B2:B5"
    targetInitCellAddress = "C1" ' Address of first cell where to begin copy the values

    Set sourceRange = Workbooks(sourceWBName).Worksheets(sourceWSName).Range(sourceRangeAddress)
    Set targetCell = Workbooks(targetWBName).Worksheets(targetWSName).Range(targetInitCellAddress)

    counter = 0

    For Each sourceCell In sourceRange

        targetCell.Offset(counter, 0).Value = sourceCell.Value

        counter = counter + 1

    Next sourceCell


    ' Copy third column
    sourceRangeAddress = "E2:E5"
    targetInitCellAddress = "F1" ' Address of first cell where to begin copy the values

    Set sourceRange = Workbooks(sourceWBName).Worksheets(sourceWSName).Range(sourceRangeAddress)
    Set targetCell = Workbooks(targetWBName).Worksheets(targetWSName).Range(targetInitCellAddress)

    counter = 0

    For Each sourceCell In sourceRange

        targetCell.Offset(counter, 0).Value = sourceCell.Value

        counter = counter + 1

    Next sourceCell

End Sub

---

Please mark this answer if it helped you.

Answer 2

Here is one way. Loop through each row of your starting range and reference each cell that way. You'll need to add in your workbook/sheet references.

Sub x()

Dim r As Range, n As Long, i As Long

Set r = Sheet1.Range("B2", Sheet1.Range("E" & Rows.Count).End(xlUp))

For i = 1 To r.Rows.Count
    n = n + 1
    Sheet2.Cells(n, 1).Value = r.Cells(i, 2).Value
    Sheet2.Cells(n, 3).Value = r.Cells(i, 1).Value
    Sheet2.Cells(n, 6).Value = r.Cells(i, 4).Value
    n = n + 1
    Sheet2.Cells(n, 1).Value = r.Cells(i, 3).Value
    Sheet2.Cells(n, 3).Value = r.Cells(i, 1).Value
    Sheet2.Cells(n, 6).Value = r.Cells(i, 4).Value * -1
Next i

End Sub

Starting data (Sheet1)

Output (Sheet2)

Answer 3

You could try:

Option Explicit

 Sub test()

    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim wbNew As Workbook
    Dim LastrowS As Long, LastrowT As Long, i As Long
    Dim Desc As String, BS As Long, PL As Long

    Set wsSource = ThisWorkbook.Worksheets("Sheet1")

    Set wbNew = Workbooks.Add
        Application.DisplayAlerts = False
            wbNew.SaveAs Filename:="C:\Users\XXXXXX\Desktop\New_Workbook_Test.xls"
        Application.DisplayAlerts = True

    Set wsTarget = wbNew.Worksheets("Sheet1")

    LastrowS = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row

        For i = 2 To LastrowS

            Desc = wsSource.Range("B" & i).Value
            BS = wsSource.Range("C" & i).Value
            PL = wsSource.Range("D" & i).Value

            LastrowS = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row

            wsTarget.Range("A" & LastrowS + 1).Value = BS
            wsTarget.Range("C" & LastrowS + 1).Value = Desc
            wsTarget.Range("F" & LastrowS + 1).Value = -Abs(BS)

            wsTarget.Range("A" & LastrowS + 2).Value = PL
            wsTarget.Range("C" & LastrowS + 2).Value = Desc
            wsTarget.Range("F" & LastrowS + 2).Value = -Abs(PL)

        Next i

 End Sub