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

 

[lunatu]

Great. thanks for the feedback.

Sorry, still bothering you with this but I think it is easiest to continue the same chat I was wondering if it would be possible to copy from columns B:G only those cells where value is >0?

 

[Saurabhj]

Hi Lunatu,

The code is working in the same way. It copies only data where value is not-blank.

I didn't get the change required. Please explain.

Thanks,
Saurabh

 

[lunatu]

Hi Lunatu,

The code is working in the same way. It copies only data where value is not-blank.

I didn't get the change required. Please explain.

Thanks,
Saurabh

Hi Saurabhj,
and thanks for the fast response!

I meant there might be cells where value is 0, so it is not blank. I would like to copy from the row only those product cells where the value is >0.

Br
Luna

 

[Saurabhj]

Hi,

Change the condition. Instead of comparing blank value, check if value > 0

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

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) > 0 Then  '''''Changed the condition
                    .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]

Hi,

Change the condition. Instead of comparing blank value, check if value > 0

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

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) > 0 Then  '''''Changed the condition
                    .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

Ok, probably should have figure that out by myself... but big thanks to you once again!

 

[Saurabhj]

In the code, I have already made the changes...Have you tried the code ?

 

[lunatu]

In the code, I have already made the changes...Have you tried the code ?

Yes, works perfectly thanks

 

[Saurabhj]

Great. thanks for the feedback.