Vba Excel-查找行中的非零值并将相应的数据拉入表中

我有一张大表，小样本如下：

样本输入：

如您所见，有一个名称列表，后面有许多百分比列，其中许多是0。我需要找到所有非零值，然后按照以下格式将所有关联的标题与此数据一起拉入表中：

样本输出：

我一直试图用公式来解决这个问题，但我认为这可能需要VBA，至少可以说我的VBA技能已经生锈了。任何帮助使这项工作将不胜感激

---

如果不能让VBA生成所有的表，那么一个公式至少可以返回每行中的所有非零值也会非常有用。谢谢

我不得不假设一个合理的数额，但我试着注意到，我确实在哪里假设了一些“必要的改变”

Sub Exporter()
Dim wsO As Worksheet, wsE As Worksheet
Dim fNameCol As Long, lNameCol As Long, deptCol As Long, comRow As Long, catRow As Long
Dim startCol As Long, endCol As Long, startRow As Long, endRow As Long
Dim workRow As Long

'error handling
On Error GoTo ErrorHandler

'speed improvement
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'this is the sheet with your raw data (change as necessary)
Set wsO = ActiveSheet

'put exported information onto a sheet called Export (change as necessary)
Set wsE = ActiveWorkbook.Sheets("Export")

'clear bold from export sheet
wsE.Cells.Font.Bold = False

'define rows/columns to work with (change as necessary)
fNameCol = 1
lNameCol = 2
deptCol = 3
comRow = 1
catRow = 2

'define start row and end row
startRow = WorksheetFunction.Match("First Name", wsO.Columns(fNameCol), 0) + 1
endRow = wsO.Cells(startRow, fNameCol).End(xlDown).Row

'define start column and end column
startCol = WorksheetFunction.Match("Company", wsO.Rows(comRow), 0) + 1
endCol = wsO.Cells(comRow, startCol).End(xlToRight).Column

'loop through all names
For x = startRow To endRow

    'increment
    workRow = workRow + 1

    'exported name
    wsE.Cells(workRow, 1) = wsO.Cells(x, lNameCol) & ", " & wsO.Cells(x, fNameCol)

    'exported headers
    workRow = workRow + 1

    With wsE.Cells(workRow, 2)
        .Value = "Company"
        .Font.Bold = True
    End With

    With wsE.Cells(workRow, 3)
        .Value = "Category"
        .Font.Bold = True
    End With

    With wsE.Cells(workRow, 4)
        .Value = "(intentional blank space)"
    End With

    With wsE.Cells(workRow, 5)
        .Value = "Department"
        .Font.Bold = True
    End With

    'increment
    workRow = workRow + 1

    'search for non-zero values
    For y = startCol To endCol

        'if not zero
        If wsO.Cells(x, y).Value > 0 Then

            'copy value and format to column A
            With wsE.Cells(workRow, 1)
                .Value = wsO.Cells(x, y).Value
                .NumberFormat = "##%"
            End With

            'copy other values
            wsE.Cells(workRow, 2).Value = wsO.Cells(comRow, y).Value
            wsE.Cells(workRow, 3).Value = wsO.Cells(catRow, y).Value
            wsE.Cells(workRow, 5).Value = wsO.Cells(x, deptCol).Value

            'increment
            workRow = workRow + 1

        End If

    Next y

Next x

'autofit columns
wsE.Columns.AutoFit

'speed improvement
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub

ErrorHandler:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Err.Number & vbCr & Err.Description, vbCritical, "Error"
Exit Sub

End Sub

---

它与提供的示例数据一起工作，但我不能保证它与您的完整工作簿一起工作。

您的示例输出不是“表”，而是一组表：输入的每个非标题行对应一个表。您无法预先知道每个子表的大小，因此无法在单元格中合理地编写公式，因为您不知道哪些输出行是标题，哪些是数据。明白了，这就是为什么我认为VBA可能更有用的原因。我认为在过去，我已经制作了公式，在很大范围内填充了所有=x的值。只是想知道是否可以根据特定行中不等于0的值进行查找。下一个条目可以放在另一列的旁边，而不是另一行的下面，这样就不会干扰非零值的填充。这样的事情可能吗？你需要做一次还是定期？