将按颜色过滤的行复制到新表

Question

我有一个看起来像这样的Excel电子表格：

|      | Job1 | Job2 | Job3 | Job4 | Job5 |
| Job1 |      |      |      |      |      |
| Job2 |      |      |      |      |      |
| Job3 |      |      |      |      |      |
| Job4 |      |      |      |      |      |
| Job5 |      |      |      |      |      |

每行和每列之间的单元格是不同的颜色。 我需要按橙色对每一列进行排序，然后将行名复制到新表中。

所以最后我会得到一个这样的表：

| Job1 | Job2 |
| Job1 | Job4 |
| Job1 | Job5 |
| Job2 | Job3 |
| Job2 | Job5 |

这个想法是，如果您可以执行Job1，则应该可以访问Job2。 这由第一张纸上的行与列之间的交点确定。 尝试用一张纸来显示名称而不是颜色。 总共有83个工作，因此手动执行此操作将使我复印4000多个。

有谁知道如何创建一个宏来一次按颜色对一列进行自动过滤并将A1列中的行内容复制到新工作表中？

Answer 1

我试图从您的描述和样本数据/结果中了解实际数据。 这就是我想出的。

以此作为活动工作表，我运行了此宏。

Sub organize_by_color()
    Dim rws As Long, c As Long, iCLR As Long, ws As Worksheet, wsT As Worksheet

    Set ws = ActiveSheet
    Set wsT = Worksheets.Add(after:=Sheets(Sheets.Count))

    iCLR = 49407 'Orange e.g. RGB(255, 192, 0)
    wsT.Cells(1, 1).Resize(1, 2) = Array("Job A", "Job B")

    With ws.Cells(1, 1).CurrentRegion
        .AutoFilter
        For c = 2 To .Columns.Count
            .AutoFilter Field:=c, Criteria1:=iCLR, Operator:=xlFilterCellColor
            With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
                rws = Application.Subtotal(103, .Columns(1))
                If CBool(rws) Then
                    .Columns(1).Copy Destination:=wsT.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
                    wsT.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(rws, 1) = ws.Cells(1, c).Value
                End If
            End With
            .AutoFilter Field:=c
        Next c
        .AutoFilter
    End With

    Set ws = Nothing
    Set wsT = Nothing

End Sub

这在工作表集合的末尾创建了一个新的工作表，结果如下。

在我看来，原始数据中的E：F列没有多大意义，因为在前三列中已经发现相反的关系，但是我认为数据编辑可能会导致冗余。 否则我的假设可能完全错误，因为数据样本并未指出矩阵中哪些单元格实际包含橙色回填。 也许您可以出于自己的目的将其转录。 如果遇到困难，请发回问题和详细信息回发。

Answer 2

我最终制作了一个Web界面，并将所有内容都转换为SQL数据库。 因此，SQL数据库和逻辑可以完成所有这些工作，而不是试图在类固醇上表现出色。