Скопировать значение из строки и столбца, соответствующих всем X в лист

Question

У меня есть задача, в которой у меня есть «Функция» в столбце A, и теги в строках со знаком «X» в середине, показывающие, какой тег и функция связаны вместе (см. Вложение)

Я пыталсячтобы создать скрипт, который может перейти к «функции (столбец A)», проверьте, найдет ли он значение «X» в той же строке, если он обнаружит, что он поднимется, и получит тег для размещения информации на новом листе.

Sheet2 будет отображать:

Функция -> и этот тег находится в той же функции, если есть несколько тегов, как в примере ниже, он будет отображаться следующим образом.

802AB Tag1

802AB Tag2

802AB Tag3

802AB Tag4

802AB Tag5

804AB Tag4

805ABTag2

У меня есть несколько сотен этих файлов, которые очень большие, так что это упрощенный пример.Спасибо за вашу помощь.

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

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, cellvalueTemp As String
    Dim WS As Workbook

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

    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Sheet2"
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Sheet3"

    Sheets("Sheet2").Cells(1, 1).Value = "Tag"
    Sheets("Sheet2").Cells(1, 2).Value = "Terminal"
    Sheets("Sheet2").Cells(1, 3).Value = "CollectiveGroupName"
    Sheets("Sheet2").Cells(1, 4).Value = "LogicalGroupName"

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 i = ColorRow To lastRow
                For j = 20 To 100 'Needs to be adjusted, possibily find the last colum and first
               If Sheet1.Cells(i, j).Value = "X" Then
                    Sheets("Sheet2").Range("A" & writeRow).Value = Sheet1.Cells(i, 1).Value
                    Sheets("Sheet2").Range("B" & writeRow).Value = Sheet1.Cells(i - 7 - (i - ColorRow), j).Value
                    Sheets("Sheet2").Range("D" & writeRow).Value = Sheet1.Cells(i - 6 - (i - ColorRow), j).Value
                    writeRow = writeRow + 1
                    Columns("A:D").EntireColumn.AutoFit
                End If
                'Ikke gjør noe
                Next j
            Next i

            If rColored Is Nothing Then

            Else
            'Ikke gjør noe
            End If

        End If
    Next cel
End Sub