Question

我有一张大纸，其中一小部分样本遵循以下格式：

示例输入：

正如您所看到的，有一个名称列表，其中包含许多百分比列，其中许多是0.我需要找到所有非零值，然后将所有关联的标题连同此数据一起拉入表中，这种格式：

示例输出：

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

如果你不能使VBA工作以生成所有表，那么至少带回每行中所有非零值的公式也将非常有用。谢谢！

Answer 1

我不得不假设相当数量，但我试着记下我在哪里做了一些必要的改变＆＃39;。

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

它与提供的示例数据一起使用，但我无法保证它可以与您的完整工作簿一起使用。

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

1 个答案: