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

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

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 2

@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 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