Блог

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

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

#excel #vba

#excel #vba

Вопрос:

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

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

Затем на листе 2 будет отображаться:

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

802AB Tag1

802AB Tag2

802AB Tag3

802AB Tag4

802AB Tag5

804AB Tag4

805AB Tag2

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

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" amp; 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" amp; 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" amp; writeRow).Value = cel.Offset(-1, 0).Value
            writeRow = writeRow   1
        End If
    End If
Next cel
End Sub

Это в основном то, что у меня есть, еще не работает, он ищет первую строку с правильным цветом формата, затем запускает цикл, проходящий по строкам, ищет X в строке, и он останавливается, мне нужно скопировать тег, в котором он нашел строку, и перейти к следующему X в том же формате.строка, после того, как все строки будут выполнены, она перейдет к следующей строке, сделайте то же самое.

Комментарии:

1. Пожалуйста, опубликуйте свои усилия по кодированию и опишите конкретные проблемы, с которыми вы столкнулись.

2. Код, который у меня есть, никогда не работал должным образом, поэтому нет причин вставлять его сюда, когда все неправильно

3. У вас меньше шансов получить помощь, если вы не показали, что сами приложили какие-либо усилия. Нерабочий код, вполне возможно, можно исправить — это то, что люди здесь делают.

Ответ №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" amp; 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" amp; writeRow).Value = Sheet1.Cells(i, 1).Value
                    Sheets("Sheet2").Range("B" amp; writeRow).Value = Sheet1.Cells(i - 7 - (i - ColorRow), j).Value
                    Sheets("Sheet2").Range("D" amp; 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