VBA function to copy into new rows depending on the colum values - excel

Question

I`m not a super experienced VBA developer and mostly relly on the Macro recorder, hence would appreciate any help by the community in helping me wrap my head around this problem. I havent used loops in the past but imagine this would be the best application for my problem.
I have the following Table;
Name
Year
Sec A
Sec B
Sec C
Joe
2020
15
20
30
Mary
2019
5
25
0
Peter
2020
7
0
0
I would like to copy/paste the name,year and amounts bigger than zero on a new sheet like the following;
Name
Year
Section
Total
Joe
2020
A
15
Joe
2020
B
20
Joe
2020
C
30
Mary
2019
A
5
Mary
2019
B
25
Peter
2020
A
7
The copy/paste operation would continune until it reaches a "0" value on the section columns, then it would continue to the next row, until it reaches the end of the rows.
Many thanks!!!

Answer 1

#BigBen's comment is right.
In Excel, highlight your source table, choose Insert Table (or press ctrl-t) making sure you check that your table has a header row.
Then, in the table ribbon (when your cursor is in the table) rename your table to "Source"
Then, in the Data ribbon, in the "Get & Transform" section, click "From Table". This will create a query that pulls from this table, and present it for editing in the Power Query Editor.
In the Home ribbon of the Power Query editor, click Manage - Reference. This will create a new query that uses/starts with the current one. I recommend renaming it (in the right sidebar).
In the home ribbon of the Power Query editor, click Advanced Editor and paste the following:
let
Source = Source,
#"Renamed Columns" = Table.RenameColumns(Source,{{"Sec A", "A"}, {"Sec B", "B"}, {"Sec C", "C"}}),
#"Unpivoted Columns" = Table.UnpivotOtherColumns(#"Renamed Columns", {"Name", "Year"}, "Attribute", "Value"),
#"Filtered Rows" = Table.SelectRows(#"Unpivoted Columns", each [Value] <> 0)
in
#"Filtered Rows"
You'll now have what you want.
Don't be scared of that code, by the way. I didn't really type all that! After creating the second query,
I double-clicked the column headers to rename them.
I highlighted the last three columns and clicked "Unpivot Columns" from the Transform ribbon.
I clicked the filter for the "Value" column to only get rows where Value wasn't 0.
and that was it!

Answer 2

This function will do that. Just create a input table named ÌnputTable and an output table named OutputTable in your worksheet
Sub Macro3()
Dim input_table As Range, output_table As Range
Set input_table = Range("InputTable")
Set output_table = Range("OutputTable")
Dim i As Integer, j As Integer, k As Integer
Dim name As String, year As String, section As String
For i = 1 To input_table.Rows.Count
name = input_table(i, 1)
year = input_table(i, 2)
For j = 3 To 5
section = Chr(62 + j)
If input_table(i, j).Value > 0 Then
k = k + 1
output_table(k, 1) = name
output_table(k, 2) = year
output_table(k, 3) = section
output_table(k, 4) = input_table(i, j)
End If
Next j
Next i
End Sub

Answer 3

Custom UnPivot RCV by Rows
Adjust the values in the constants section.
The Code
Option Explicit
Sub UnPivotRCVbyRowsCustom()
' Define constants.
Const srcName As String = "Sheet1" ' Source Worksheet Name
Const srcFirst As String = "A1" ' Source First Cell Range
Const rlCount As Long = 2 ' Row Labels (repeating columns) Count
Const vException As Variant = 0 ' Value Exception
Const dstName As String = "Sheet2" ' Destination Worksheet Name
Const dstFirst As String = "A1" ' Destination First Cell Range
Const HeaderList As String = "Name,Year,Section,Total"
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Source Range.
Dim ws As Worksheet: Set ws = wb.Worksheets(srcName)
Dim rng As Range
Set rng = defineEndRange(ws.Range(srcFirst).CurrentRegion, srcFirst)
' Write values from Source Range to Data Array.
Dim Data As Variant: Data = rng.Value
Dim srCount As Long: srCount = UBound(Data, 1) ' Source Rows Count
Dim scCount As Long: scCount = UBound(Data, 2) ' Source Columns Count
' Calculate Exceptions Count.
Set rng = rng.Resize(srCount - 1, scCount - rlCount) _
.Offset(1, rlCount)
Dim eCount As Long: eCount = Application.CountIf(rng, vException)
' Rename column labels in Data Array.
Dim fvCol As Long: fvCol = 1 + rlCount ' First Value Column
Dim j As Long ' Source Columns Counter
For j = fvCol To scCount
Data(1, j) = Right(Data(1, j), 1)
Next j
' Define Result Array.
Dim drCount As Long ' Destination Rows Count
drCount = (srCount - 1) * (scCount - rlCount) - eCount + 1
Dim dcCount As Long: dcCount = rlCount + 2 ' Destination Columns Count
Dim Result As Variant: ReDim Result(1 To drCount, 1 To dcCount)
' Write headers to Result Array.
Dim Headers() As String: Headers = Split(HeaderList, ",")
For j = 1 To dcCount
Result(1, j) = Headers(j - 1)
Next j
' Write values from Data Array to Result Array.
Dim i As Long ' Source Rows Counter
Dim k As Long: k = 1 ' Destination Rows Counter
Dim l As Long ' Destination Columns Counter
For i = 2 To srCount
For j = fvCol To scCount
If Data(i, j) <> vException Then
k = k + 1
For l = 1 To rlCount
Result(k, l) = Data(i, l)
Next l
Result(k, l) = Data(1, j)
Result(k, l + 1) = Data(i, j)
End If
Next j
Next i
' Write values from Result Array to Destination Range.
With wb.Worksheets(dstName).Range(dstFirst).Resize(, dcCount)
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(drCount).Value = Result
End With
End Sub
Function defineEndRange( _
rng As Range, _
ByVal FirstCellAddress As String) _
As Range
If Not rng Is Nothing Then
With rng.Areas(1)
On Error Resume Next
Dim cel As Range: Set cel = .Worksheet.Range(FirstCellAddress)
On Error GoTo 0
If Not cel Is Nothing Then
If Not Intersect(rng.Areas(1), cel) Is Nothing Then
Set defineEndRange = cel.Resize( _
.Rows.Count + .Row - cel.Row, _
.Columns.Count + .Column - cel.Column)
End If
End If
End With
End If
End Function

Answer 4

I am new to VBA as well, so I am taking this as a practice. Here is the code I wrote. May not be the best solution but it does work.
Sub copyandpastedata()
Dim lastrow As Long
Dim lastcol As Long
Dim i As Integer
Dim ws As Worksheet
Dim cell As Range
Dim char As String
'Define last position where a data exist
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
lastcol = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
'Delete all worksheets other than sheet1(where the raw data is)
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> "Sheet1" Then
ws.Delete
End If
Next
Application.DisplayAlerts = True
'Create a new sheet and name it to NewData
Sheets.Add(after:=Sheet1).Name = "NewData"
With Sheets("NewData")
.Range("A1") = "Name"
.Range("B1") = "Year"
.Range("C1") = "Section"
.Range("D1") = "Total"
End With
'Loop through raw data and find matches
i = 2
With Sheet1
For Each cell In .Range("C2", .Cells(lastrow, lastcol))
If VBA.IsNumeric(cell) Then
If cell > 0 Then
.Cells(cell.Row, 1).Copy Sheets("NewData").Cells(i, 1) 'Copy Name to the new sheet
.Cells(cell.Row, 2).Copy Sheets("NewData").Cells(i, 2) 'Copy Year to the new sheet
char = Right(.Cells(1, cell.Column), 1) 'Look for section letter ID
Sheets("NewData").Cells(i, 3) = char 'Copy section to the new sheet
.Cells(cell.Row, cell.Column).Copy Sheets("NewData").Cells(i, 4) 'Copy Total to the new sheet
i = i + 1
End If
End If
Next
End With
End Sub