从表格中所有X对应的行和列中复制值

Question

我有一个任务，其中我在A列中有“功能”，并且标签的行中间有“ X”，显示了哪些标签和功能连接在一起（请参阅附件）

我一直在尝试制作一个可以转到“函数（A列）”的脚本，检查它是否在同一行中找到值“ X”，如果找到，它将上升并获得标签发布新工作表中的信息。

Sheet2随后将显示：

Function->和thich Tag在同一函数中，如果像下面的示例中那样的标签很少，它将显示如下。

802AB Tag1

802AB Tag2

802AB Tag3

802AB Tag4

802AB Tag5

804AB Tag4

805AB Tag2

我几乎没有这些文件的Hundret，它们很大，所以这是简化的示例。谢谢您的帮助。

https://imgur.com/a/xo0TEZs

Sub test()
Dim rng As Range
Dim cel As Range
Dim lastRow As Long
Dim writeRow As Long
Dim rCell As Range
Dim lColor, ColorRow As Long
Dim rColored As Range
Dim i, j As Integer
Dim temprow As Long
Dim lnRow As Long, lnCol As Long

lColor = RGB(255, 153, 204)
Set rColored = Nothing

lastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
writeRow = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1

Set rng = Sheets("Sheet1").Range("A6:A" & lastRow)

For Each cel In rng
  If cel.Interior.Color = lColor Then
    ColorRow = cel.Row + 1

    For j = ColorRow + 1 To lastRow

        For i = ColorRow + 1 To lastRow

        lnCol = Sheet1.Cells(i, 1).EntireRow.Find(What:="X", 
        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlBycolumn, 
        SearchDirection:=xlNext, MatchCase:=False).Column
   '   Sheets("Sheet2").Range("A" & writeRow).Value = cel.Offset(0, 0).Value
     '   writeRow = writeRow + 1
        Next i

    Next j
    'End If

        If rColored Is Nothing Then

        Else
            Sheets("Sheet2").Range("A" & writeRow).Value = cel.Offset(-1, 0).Value
            writeRow = writeRow + 1
        End If
    End If
Next cel
End Sub

这基本上是我所拥有的，尚未运行，它搜索具有正确格式颜色的第一行，然后启动遍历行的循环，在行中搜索X，然后停止，我需要复制标签找到行的地方，然后转到同一行中的下一个X，所有行完成后，它应该转到下一行。

Answer 1

settings = {
    actions: {
        edit: false,
        delete: false
    }
}