Захват данных, а затем создать цикл в существующем коде

Question

Я создал электронную таблицу, в которой есть макрос, который удаляет и перемещает на новую вкладку строку, когда статус в столбце A помечен как «оплаченный».Мне нужно сделать еще один шаг вперед, чтобы, если статус помечен как «оплаченный» и номер счета в столбце D совпадает с той же строкой, что все те же номера счета-фактуры также будут перемещены на новую вкладку.

Какой код будет захватывать номер счета-фактуры для этой строки?

Затем выполните цикл for внутри первого, который проходит по всем строкам и перемещает все те, которые соответствуют номеру счета-фактуры.Вставить после If CStr(xRg(K).Value) = "paid".текущее изображение электронной таблицы.Код, который я использую ниже.Изображение является фрагментом таблицы.В примере Сара Филлипс имеет данные в строках 9-12 со статусом «оплачено» в столбце 9. Строка 9. Мне нужно, чтобы все 4, у которых был одинаковый счет №, переместились в новую электронную таблицу.

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

Sub TransferData()

Dim xRg As Range
Dim xCell As Range
Dim I As Long, J As Long, K As Long

I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("Sheet1").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
    If CStr(xRg(K).Value) = "paid" Then
        xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
        xRg(K).EntireRow.Delete
        If CStr(xRg(K).Value) = "paid" Then
            K = K - 1
        End If
        J = J + 1
    End If
Next
Application.ScreenUpdating = True


 End Sub

Я ожидаю, что строки с соответствующими номерами счетов будут перемещены, когда строка A помечена как «оплаченная» имакрос выполнен.

Answer 1

Я бы порекомендовал следующие изменения.

• Используйте For петлю. Это проще, и вы сможете легче следовать.
• Удалите строки в конце макроса. Это можно сделать с помощью KillRnG в приведенном ниже коде.

• Вы можете использовать Offset для сбора информации из других столбцов в соответствующей строке. Смотрите мой пример.

  'If you insert this immediately after you turn off screen 
  'updating you can loop through your rows.
  dim aCell as Range
  For Each aCell In Intersect(Range("A:A", ActiveCell.UsedRange)).Cells
  
      If UCase(aCell.Value) = "PAID" Then
          'do your thing of copying the row to some other other sheet.
  
           'set the row for deletion... this will be done at the end.
            Set killRNG = Union(killRNG, aCell.EntireRow)
  
      Debug.Print "This is the invoice: " & aCell.Offset(0, 3).Value
  End If
  
  Next cell
  
  'This will delete whatever you wanted
  killRNG.ClearContents
  killRNG.Delete