0 votes
in VBA by Beginner (16 points)

Hi everyone

I have tried googling a way to do this but have not managed to find a way around.

My data is sorted out like below:

 ApplePearPeach
Harry3  
Andrew 21
William1  
Philip23 

 

 

I need to then report in another sheet where each "coordinate" presents a row of data.

 

FruitPersonAmount
AppleHarry3
PearAndrew2
PeachAndrew1

 

I need the macro skip over the blanks, but keep reporting down as far the Column A goes in the original sheet, but cannot determine how many columns across.

 

I don't even know how and where to start :( Would appreciate any insight into this.

2 Answers

+2 votes
by Expert (754 points)
edited by

Try this code

Sub Test()
    Dim a, b, i As Long, j As Long, k As Long

    a = Sheets("Sheet1").Range("A1").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * 3, 1 To 3)

    For i = 2 To UBound(a, 1)
        For k = 2 To UBound(a, 2)
            If a(i, k) <> "" Then
                j = j + 1
                b(j, 1) = a(1, k)
                b(j, 2) = a(i, 1)
                b(j, 3) = a(i, k)
            End If
        Next k
    Next i

    With Sheets("Sheet1").Range("I1")
        .Resize(, UBound(b, 2)).Value = Array("Fruit", "Person", "Amount")
        .Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
    End With
End Sub

 

I have played around to make a public procedure for the code

You can try this code too

Sub Test_RowsMatrix()
    With Worksheets("Sheet1")
        RowsMatrix .Range("A1"), .Range("I1"), Array("Fruit", "Person", "Amount"), 3
    End With
End Sub

Sub RowsMatrix(sourceCel As Range, tagretCel As Range, aHeaders As Variant, colNum As Long)
    Dim a, b, i&, j&, k&, x&

    a = sourceCel.CurrentRegion.Value
    ReDim b(1 To UBound(a, 1) * colNum, 1 To UBound(aHeaders) + 1)

    For i = 2 To UBound(a, 1)
        For k = 2 To UBound(a, 2)
            If a(i, k) <> "" Then
                j = j + 1
                
                For x = 1 To colNum
                    b(j, x) = a(IIf(x = 1, 1, i), IIf(x = 2, 1, k))
                Next x
            End If
        Next k
    Next i

    With tagretCel
        .Resize(, UBound(b, 2)).Value = aHeaders
        .Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
    End With
End Sub

 

by Beginner (16 points)
+1
Thank you soooooo much for this! This has really helped me with my work.
by Beginner (16 points)

I've just hit a second hurdle.

Is there a way to get excel to get a cell value as the destination cell and the next cell as the value?

NotifyDetailsCellQTYCellSupplier
YesApplesA25B2ABC
DelayPears    
YesPeachersA33B3DEF

Is it possible to copy the value of D2 here (ie 5) to cell A2 in sheet2? and then here E2 (ie ABC) to cell B2 and keep going until there is none left?

by Expert (754 points)
I think the structure is different. Can you give us the final desired output in sheet2 based on the input table you posted in your comment?
by Beginner (16 points)

Thank you so much for your assistance!

This is where we start from: (slight change from the one above because I made a mistake)

NotifyDetailsCellQtyCellSupplierCellQtyCellSupplier
YesApplesB25C2ABCB33C3DEF
DelayPears        
YesPeachesB44C4XYZ    

To

DetailsQtySupplier
Apples5ABC
Apples3DEF
Peaches4XYZ

So the cell reference is on the left of the value I want copied over :S

0 votes
by Expert (754 points)

With the new structure you can use loops in simple way to reach your goal

Try this code

Sub Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    Dim lc          As Long
    Dim r           As Long
    Dim c           As Long
    Dim m           As Long
    
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set sh = ThisWorkbook.Worksheets("Sheet2")
        lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
        lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        sh.Cells.ClearContents
        sh.Range("A1").Resize(, 3).Value = Array("Details", "Qty", "Supplier")
        
        For r = 2 To lr
            For c = 4 To lc Step 4
                If ws.Cells(r, c).Value <> "" Then
                    m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
                    sh.Cells(m, 1).Value = ws.Cells(r, 2).Value
                    sh.Cells(m, 2).Value = ws.Cells(r, c).Value
                    sh.Cells(m, 3).Value = ws.Cells(r, c).Offset(, 2).Value
                End If
            Next c
        Next r
    Application.ScreenUpdating = True
End Sub

 

by Beginner (16 points)

Thanks again for such a prompt response.

It appears to have done exactly that.

If the Notify Yes / No / Delay is in another column further right, where would I modify that rule?

I tried changing B2 to C8 hoping that it might move the 5 to cell reference 8 but the output had the 5 in the same spot ie still existing happily in B2.

Also, if I have more than the 3, can I just add on?

 sh.Cells(m, 3).Value = ws.Cells(r, c).Value
 sh.Cells(m, 4).Value = ws.Cells(r, c).Value
 sh.Cells(m, 5).Value = ws.Cells(r, c).Value

Thanks again!

by Expert (754 points)
And what about "Apples" for example, there is reference for a range to put in ..

I see the issue is unlogical a little ..
by Beginner (16 points)
I think I see the problem now.

No wonder no one wants to do the job... and have been doing it the manual way for years.
by Expert (754 points)

Try this although it is not logical for me

Sub Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim lr          As Long
    Dim lc          As Long
    Dim r           As Long
    Dim c           As Long
    Dim m           As Long
    
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Set sh = ThisWorkbook.Worksheets("Sheet2")
        lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
        lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        sh.Cells.ClearContents
        sh.Range("A1").Resize(, 3).Value = Array("Details", "Qty", "Supplier")
        
        For r = 2 To lr
            For c = 4 To lc Step 4
                If ws.Cells(r, c).Value <> "" Then
                    m = Range(ws.Cells(r, c).Offset(, -1).Value).Row
                    sh.Cells(m, 1).Value = ws.Cells(r, 2).Value
                    sh.Range(ws.Cells(r, c).Offset(, -1).Value).Value = ws.Cells(r, c).Value
                    sh.Range(ws.Cells(r, c).Offset(, 1).Value).Value = ws.Cells(r, c).Offset(, 2).Value
                End If
            Next c
        Next r
    Application.ScreenUpdating = True
End Sub

 

Welcome to wellsr Q&A
wellsr Q&A is the VBA and Python programming community that rewards you for learning how to code.

Getting Started
Register
VBA Cheat Sheets (On Sale Now)

Earn free prizes for asking VBA and Python questions and for answering questions asked by others in our community.

Looking for something else? Hire our professional VBA Help, instead.

What makes us different?
Our points system rewards you with a chance for free gifts based on the quality of your questions and answers. All you have to do is post and you could get rewarded, like these members:

Hightree $10 Amazon Gift Card
Thales1 $10 Amazon Gift Card
runfunke $10 Amazon Gift Card
coolag $10 Amazon Gift Card
Siew Hun $10 Amazon Gift Card

So, why don't you join us? It really is an encouraging way to motivate members in our VBA and Python community.

Register

For more programming tips visit the VBA Tutorials Blog and the Python Tutorials Blog.

...