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

Question

I have an Excel spreadsheet that looks something like this:

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

The cells between each row and column are different colors. I need to sort each column by the color orange and then copy the row names to a new sheet.

So in the end I would have a sheet like this:

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

The idea is if you can do Job1 you should have access to Job2. That is determined by the intersection between column and row from the first sheet. Try to have a sheet that shows the names instead of the colors. In all there are 83 jobs so manually doing this would have me copying over 4000.

Does anyone know how to create a macro to autofilter by color one column at a time and copy the contents of the row in column A1 to a new sheet?

Answer 1

I tried to make some sense of the actual data from your description and sample data/results. This is what I came up with.

With that as the active worksheet, I ran this macro.

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

This created a new worksheet at the end of the worksheet collection with the following results.

To my mind, there isn't much point in having columns E:F in the original data as any relationship noted there would already have been discovered in its reverse through the first three columns but I suppose that data redaction might account for the redundancy. Or I could be completely wrong in my assumptions as the data sample was not noted as to which cells in the matrix actually contained orange color backfill. Perhaps you will be able to transcribe this for your own purposes. Post back with questions and specifics if you run into difficulty.

Answer 2

I ended up making a web interface and converting everything over to a SQL database. So the SQL database and logic could do all this instead of trying to put excel on steroids.