从符合条件的行转置值

Question

我正在尝试分析各公司为某段火车旅程提供的折扣，并相应地列出公司名称和折扣。

输入数据集如下图所示：

我想要做的是基本上转置数据集并创建以下输出，其中折扣是＆gt; 0并返回公司/列名称。 （见下文）

我尝试使用以下公式：

{=INDEX(A1:F7,SMALL(IF(AND(A2:A7=H2,B2:F2>0),COLUMNS(B1:F1)),COLUMNS(1:1))-1,3)} 

- 这似乎总能产生#NUM！错误

=INDEX(A1:F7, MATCH(H2,A2:A7,0),MATCH(I2,B1:F1,0))

• 这只有在我列出所有可能的路线且每家公司都有一条路线时才有效，即使折扣为0.鉴于我有40家公司和15000多条路线，我真的不想创建一长串的LONPAR，每个公司都在B栏，其次是LONFRA等。

我有什么遗漏，或者您可以提供的任何指导或功能来帮助我获得解决方案吗？

Answer 1

以下代码似乎可以相当有效地拆分您的火车折扣表。

Option Explicit

Sub qwewretq()
    Dim a As Long, b As Long, h As Long, aDISs As Variant

    With Worksheets("Sheet10")
        With .Cells(1, 1).CurrentRegion
            aDISs = .Cells.Value2
            h = .Columns.Count + 2
        End With
        .Cells(1, h).CurrentRegion.ClearContents
        .Cells(1, h).Resize(1, 3) = Array("route", "company", "discount")
        For a = 2 To UBound(aDISs, 1)
            For b = 2 To UBound(aDISs, 2)
                If aDISs(a, b) > 0 Then
                    If IsError(Application.Match(aDISs(a, 1), .Columns(h), 0)) Then
                        .Cells(Rows.Count, h + 1).End(xlUp).Offset(1, -1) = aDISs(a, 1)
                    End If
                    .Cells(Rows.Count, h + 1).End(xlUp).Offset(1, 0).Resize(1, 2) = _
                        Array(aDISs(1, b), aDISs(a, b))
                End If
            Next b
        Next a
    End With
End Sub

有些领域可以进行调整以提高效率，尤其是.ScreenUpdating property和.EnableEvents property等应用环境设置。对于非常大的数据块，构建目标数组并将已解析的数据转储回工作表 en masse 也可能有所帮助。您应该能够非常轻松地格式化目标表的百分比和任何视觉上的赞美。