Excel Rows and columns having the same value should form as a table

Question

Input:

enter image description here

Output:

enter image description here

Sub Macro3()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+t
'
j = 1
a = Worksheets("Allocation").Cells(Rows.Count, j).End(xlUp).row

For i = 2 To a
  If Worksheets("Allocation").Cells(i, 2).Value > 0 Then
    Worksheets("Allocation").Rows(i).Copy
    Worksheets("Output").Activate
    b = Worksheets("Output").Cells(Rows.Count, 1).End(xlUp).row
    Worksheets("Output").Cells(b + 1, 1).Select

    ActiveSheet.Paste
    Worksheets("Allocation").Activate

    j = j + 1
  End If
Next

Application.CutCopyMode = False
ThisWorkbook.Worksheets("Allocation").Cells(1, 1).Select

End Sub

So you have shown two images, one input and a output, and some code. Is the output the desired output or the actual output and what's your question? (Please edit your question, I've already done some basic editing) — Dominique, Nov 14 '22 at 10:56
Input table : raw data in Allocation excel sheet Output table : After running the macro, I want to have the output in Output excel sheet (Desired output) which was not happening so I posted here for the help — TARUN KUMAR, Nov 14 '22 at 11:17
I recommend that you read [How to avoid select](https://stackoverflow.com/a/23913882/16578424) and [How to avoid copy/pase](https://stackoverflow.com/a/64611707/16578424) - if you apply those adivses, the error will most likely be gone. — Ike, Nov 14 '22 at 12:18

score 0 · Answer 1 · answered Nov 14 '22 at 16:47

To go through your table like that, you'd need to work in two for loops, 1 for the rows and 1 for the columns.

Sub getAllOnes()
    Dim lColumn As Long, lastrow As Long, lRowO As Long
    Dim wsA As Worksheet, wsO As Worksheet
    Dim sCopy As String
    
    Set wsA = ActiveWorkbook.Worksheets("Allocation")
    Set wsO = ActiveWorkbook.Worksheets("Output")
    lRowO = 2 'start row of your Output
    
    lastrow = wsA.Range("A" & Rows.Count).End(xlUp).Row
    lColumn = wsA.Cells(1, Columns.Count).End(xlToLeft).Column
    
    For j = 2 To lColumn 'looping through columns
        For i = 2 To lastrow 'looping through your rows
            If Cells(i, j).Value2 > 0 Then 'assuming you only have 1's in the table, this should suffice
                wsO.Cells(lRowO, 1).Value2 = wsA.Cells(i, 1).Value2 'using values makes sure you get the value but don't need to keep switching between sheets or copying
                wsO.Cells(lRowO, 2).Value2 = wsA.Cells(1, j).Value2
                lRowO = lRowO + 1
            End If
        Next i
    Next j
End Sub

This outta do it. If anything is unclear, let me know.

Excel Rows and columns having the same value should form as a table

1 Answers1