根据列值复制到新行的 VBA 函数

Question

我不是一个经验丰富的 VBA 开发人员，并且主要依赖于宏记录器，因此如果社区帮助我解决这个问题，我将不胜感激。我过去没有使用过循环，但想象这将是解决我的问题的最佳应用程序。

我有下表；

Name	Year	Sec A	Sec B	Sec C
Joe	2020	15	20	30
Mary	2019	5	25	0
Peter	2020	7	0	0

我想将姓名、年份和大于零的金额复制/粘贴到新工作表上，如下所示；

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

复制/粘贴操作将继续，直到它在部分列上达到“0”值，然后它将继续到下一行，直到它到达行的末尾。

非常感谢！！！

Answer 1

@BigBen 的评论是对的。

在 Excel 中，突出显示您的源表格，选择“插入表格”（或按 ctrl-t），确保检查您的表格是否有标题行。

然后，在表格功能区中（当您的光标在表格中时）将您的表格重命名为“源”

然后，在“数据”功能区的“获取和转换”部分中，单击“从表”。这将创建一个从此表中提取的查询，并将其呈现在 Power Query 编辑器中以供编辑。

在 Power Query 编辑器的主页功能区中，单击管理 - 参考。这将创建一个使用/从当前查询开始的新查询。我建议重命名它（在右侧边栏中）。

在 Power Query 编辑器的主页功能区中，单击高级编辑器并粘贴以下内容：

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"

现在你会得到你想要的。

顺便说一句，不要害怕那个代码。我并没有真正输入所有这些！创建第二个查询后，

• 我双击了列标题来重命名它们。
• 我突出显示了最后三列，然后单击了“转换”功能区中的“Unpivot Columns”。
• 我单击了“值”列的过滤器以仅获取值不为 0 的行。

就是这样！

Answer 2

这个函数会做到这一点。只需在工作表中创建一个名为 ÌnputTable 的输入表和一个名为 OutputTable 的输出表

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

按行自定义 UnPivot RCV

• 调整常量部分中的值。

守则

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

我也是 VBA 新手，所以我将其作为练习。这是我写的代码。可能不是最好的解决方案，但它确实有效。

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