VBA: Copy + paste from workbook to another and rearrange columns into rows

[lunatu]

Hi,
Im having an situation where I dont where to start from, hopefully getting some help from here
I have workbook 1 where I have one row per customer and products listed in columns and values in a row. I need to copy all the products with values based on the status (=won) into another workbook and rearrange the columns into rows, so there might be multiple rows per customer. Below pictures to help understand what Im looking for:

Workbook 1

Workbook 2

 

[Saurabhj]

Hi Lunatu,

Use below code:

Option Explicit

Sub copyData()
Dim wb As New Workbook, rowToCopy As Integer
Dim lRow As Integer, nRow As Integer, rowno As Integer, colno As Integer

'Create workbook with name ProductData in which data will be copied. Keep the file open.

Set wb = Workbooks("ProductData.xlsx")
lRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

nRow = wb.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1

rowToCopy = nRow

For rowno = 2 To lRow
    If ThisWorkbook.Sheets("Sheet1").Range("H" & rowno) = "won" Then
        For colno = 2 To 7
            If ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno) <> "" Then
                ThisWorkbook.Sheets("Sheet1").Range("A" & rowno).Copy wb.Sheets("Sheet1").Range("A" & rowToCopy) 'To copy customer name
                ThisWorkbook.Sheets("Sheet1").Cells(1, colno).Copy wb.Sheets("Sheet1").Range("B" & rowToCopy) 'To copy product name
                ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno).Copy wb.Sheets("Sheet1").Range("C" & rowToCopy) 'To copy product value
                rowToCopy = rowToCopy + 1
            End If
        Next
    End If
Next
End Sub

 

[lunatu]

Awesome - this works perfectly! Thanks

 

[Saurabhj]

Great. Thanks for the feedback.

 

[lunatu]

Hi!

Still one question: I added formulas in workbook 1 columns B to C, how it will copy only values not formulas?

 

[lunatu]

Hi Lunatu,

Use below code:

Option Explicit

Sub copyData()
Dim wb As New Workbook, rowToCopy As Integer
Dim lRow As Integer, nRow As Integer, rowno As Integer, colno As Integer

'Create workbook with name ProductData in which data will be copied. Keep the file open.

Set wb = Workbooks("ProductData.xlsx")
lRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

nRow = wb.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1

rowToCopy = nRow

For rowno = 2 To lRow
    If ThisWorkbook.Sheets("Sheet1").Range("H" & rowno) = "won" Then
        For colno = 2 To 7
            If ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno) <> "" Then
                ThisWorkbook.Sheets("Sheet1").Range("A" & rowno).Copy wb.Sheets("Sheet1").Range("A" & rowToCopy) 'To copy customer name
                ThisWorkbook.Sheets("Sheet1").Cells(1, colno).Copy wb.Sheets("Sheet1").Range("B" & rowToCopy) 'To copy product name
                ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno).Copy wb.Sheets("Sheet1").Range("C" & rowToCopy) 'To copy product value
                rowToCopy = rowToCopy + 1
            End If
        Next
    End If
Next
End Sub

Hi,

still few question if you could help me. I modified the code a little bit:
- column H can be either "won" or "part-wont", the code should copy if either of them are in the cell
- in column I i have added date and I want to copy all rows from yesterday --> current date - 1
- there must be text in column A
- I added formulas in columns B-G and I want to paste the values not the formulas.

The code I modified is not working:

Sub copyData()
Dim wb As New Workbook, rowToCopy As Integer
Dim lRow As Integer, nRow As Integer, rowno As Integer, colno As Integer

Set wb = Workbooks("ProductData.xlsx")
lRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

nRow = wb.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1

rowToCopy = nRow

For rowno = 2 To lRow
If ThisWorkbook.Sheets("Sheet1").Range("H" & rowno) = "won" Or ThisWorkbook.Sheets("Sheet1").Range("Q" & rowno) = "part-won" And ThisWorkbook.Sheets("Sheet1").Range("I" & rowno) = Date - 1 And ThisWorkbook.Sheets("Sheet1").Range("A" & rowno) > 0 Then
For colno = 2 To 7
If ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno) <> "" Then
ThisWorkbook.Sheets("Sheet1").Range("A" & rowno).Copy wb.Sheets("Sheet1").Range("A" & rowToCopy)
ThisWorkbook.Sheets("Sheet1").Cells(1, colno).Copy wb.Sheets("Sheet1").Range("B" & rowToCopy)
ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno).Copy wb.Sheets("Sheet1").Range("C" & rowToCopy)
rowToCopy = rowToCopy + 1
End If
Next
End If
Next
End Sub

 

[Saurabhj]

Hi!

Still one question: I added formulas in workbook 1 columns B to C, how it will copy only values not formulas?

Hi,

To paste only values use below:

ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno).Copy
wb.Sheets("Sheet1").Range("C" & rowToCopy).PasteSpecial xlPasteValues

 

[Saurabhj]

Hi Lunatu,

Check below modified code:

Dim wb As New Workbook, rowToCopy As Integer
Dim lRow As Integer, nRow As Integer, rowno As Integer, colno As Integer

'Create workbook with name ProductData in which data will be copied. Keep the file open.

Set wb = Workbooks("ProductData.xlsx")
lRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

nRow = wb.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1

rowToCopy = nRow

Application.ScreenUpdating = False
With ThisWorkbook
    For rowno = 2 To lRow
        If (.Sheets("Sheet1").Range("H" & rowno) = "won" Or .Sheets("Sheet1").Range("H" & rowno) = "part-won") _
        And .Sheets("Sheet1").Range("A" & rowno) <> vbNullString And .Sheets("Sheet1").Range("I" & rowno) >= Date - 1 Then
            For colno = 2 To 7
                If .Sheets("Sheet1").Cells(rowno, colno) <> "" Then
                    .Sheets("Sheet1").Range("A" & rowno).Copy wb.Sheets("Sheet1").Range("A" & rowToCopy) 'To copy customer name
                    .Sheets("Sheet1").Cells(1, colno).Copy wb.Sheets("Sheet1").Range("B" & rowToCopy) 'To copy product name
                    .Sheets("Sheet1").Cells(rowno, colno).Copy
                    wb.Sheets("Sheet1").Range("C" & rowToCopy).PasteSpecial xlPasteValues 'To copy product value as values only
                    rowToCopy = rowToCopy + 1
                End If
            Next
        End If
    Next
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub

 

[lunatu]

This is working perfectly, thanks again!

 

[Saurabhj]

Great. thanks for the feedback.