как скопировать данные на лист, если условие выполнено, а если нет, добавить данные в последнюю строку? VBA

Лист данных (источник данных) содержит данные в следующем формате:

Case ID      Contact     Email           Address
999          Jim         [email protected]     (blank)
998          (blank)     (blank)         (blank)

На листе проблем (назначение) есть список идентификаторов дел с уже заполненным вопросом 1. Существует список проблем (проблемы 2 и далее) в формате ниже + желаемый результат:

Case ID      Issue 1        Issue 2      Issue 3
999                                      address
998          contact        email        address

ЦЕЛЬ. Поскольку некоторые идентификаторы обращений уже присутствуют в проблемах, цель состоит в том, чтобы заставить макрос сканировать лист данных и, если идентификатор обращения НАЙДЕН,

  • проверьте, не пусто ли поле «Выпуск 2». Если это так, получите заголовок столбца и вставьте его в ту же строку, где находится идентификатор дела в Issues.
  • если идентификатор обращения НЕ НАЙДЕН, добавьте идентификатор обращения к последней строке проблем, столбец A, а также добавьте заголовок столбца к столбцу проблемы 2 в той же строке.

Цель состоит в том, чтобы выделить проблемы в таблице данных с несколькими условиями и вставить их в таблицу проблем. В этом случае с приведенным ниже кодом оператор IF ищет ячейки, которые имеют Interior.ColorIndex = 2 на листе данных.

ПРОБЛЕМА: мой текущий код не выполняет цикл правильно и добавляет ненайденный CASE ID в последнюю строку листа 1. Кроме того, я не уверен, что мои счетчики настроены правильно. Любая помощь будет оценена по достоинству.

Sub IssuesData()

Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastrow As Long
Dim lastrow2 As Long
Dim lastrow3 As Long
Dim i As Long
Dim j As Long
Dim wb As Workbook

lastrow = ThisWorkbook.Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
lastrow3 = ThisWorkbook.Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).Row

For j = 2 To lastrow3
    For i = 2 To lastrow
        If ThisWorkbook.Sheets("Data").Cells(i, 10).Interior.ColorIndex = 2 Then
            If Sheets("Data").Cells(i, 3) = Sheets("Issues").Cells(j, 1) Then

            Sheets("Issues").Cells(j, "D") = Sheets("Data").Cells(1, 10)

            End If
        j = j + 1


            Else
                If ThisWorkbook.Sheets("Data").Cells(i, 10).Interior.ColorIndex = 2 Then
                lastrow2 = ThisWorkbook.Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).Row
                Sheets("Data").Cells(i, 3).Copy
                Sheets("Issues").Range("A" & lastrow2 + 1).PasteSpecial xlPasteValues
                Sheets("Data").Cells(1, 10).Copy
                Sheets("Issues").Range("D" & lastrow2 + 1).PasteSpecial xlPasteValues
                End If
            End If

    Next i
Next j

End Sub

loops excel range find vba
person VBAWARD    schedule 19.02.2019    source источник

Ответы (1)


arrow_upward
0
arrow_downward

Получил это работает - надеюсь, что это поможет кому-то!

Sub ReadC1LegalContact()

Dim frng As Variant
Dim i As Long
Dim lastrow As Long
Dim pasteRow As Long



    With ThisWorkbook

        lastrow = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row

        For i = 2 To lastrow

            If Sheets("Data").Cells(i, 60).Interior.ColorIndex = 1 Then
                Set frng = Sheets("Issues").Range("A:A").Find(Sheets("Data").Cells(i, 3), , xlValues, xlWhole)

                If Not frng Is Nothing Then
                    If .Sheets("Issues").Cells(frng.Row, "B") = "" Then
                       .Sheets("Issues").Cells(frng.Row, "B") = .Sheets("Data").Cells(1, 60)
                    End If
                Else
                    pasteRow = .Sheets("Issues").Range("A" & Rows.Count).End(xlUp).Row + 1
                    .Sheets("Issues").Range("A" & pasteRow) = .Sheets("Data").Cells(i, 3)
                    .Sheets("Issues").Range("B" & pasteRow) = .Sheets("Data").Cells(1, 60)
                End If
            End If

        Next i

    End With
End Sub
person VBAWARD    schedule 19.02.2019