Привет и заранее спасибо

В настоящее время я работаю над vba для копирования и вставки строк с одного рабочего листа на другой, когда определенное значение вводится в ячейку в диапазоне «O».

В настоящее время мой vba работает нормально, однако я хочу, чтобы он копировал из столбцов от A до Z, а не из всей строки.

Пожалуйста, смотрите ниже мой текущий код:

Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Demand Log").UsedRange.Rows.Count
J = Worksheets("Change Log").Cells(Worksheets("Change Log").Rows.Count, "B").End(xlUp).Row
If J = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("Change Log").Range) = 0 Then J = 0
End If
Set xRg = Worksheets("Demand Log").Range("O5:O" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
    If CStr(xRg(K).Value) = "Change Team" Then
    J = J + 1
        xRg(K).EntireRow.Copy Destination:=Worksheets("Change Log").Range("A" & J)
        xRg(K).EntireRow.Delete
    End If
Next
Application.ScreenUpdating = True
0
Adamlh77 2 Янв 2018 в 17:38

2 ответа

Лучший ответ

При удалении строк нужно работать снизу вверх.

И вы можете использовать Intersect:

Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("Demand Log").UsedRange.Rows.Count
J = Worksheets("Change Log").Cells(Worksheets("Change Log").Rows.Count, "B").End(xlUp).Row
If J = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("Change Log").Range) = 0 Then J = 0
End If
Set xRg = Worksheets("Demand Log").Range("O5:O" & I)

Application.ScreenUpdating = False
For K = xRg.Count To 1 Step -1
    If CStr(xRg(K).Value) = "Change Team" Then
        J = J + 1
        With Worksheets("Demand Log")
            Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Copy Destination:=Worksheets("Change Log").Range("A" & J)
            Intersect(.Rows(xRg(K).Row), .Range("A:Z")).Delete xlShiftUp
        End With
    End If
Next
Application.ScreenUpdating = True
1
Scott Craner 2 Янв 2018 в 15:07

Используйте метод изменения размера. Кстати, при удалении строк всегда выполняйте цикл назад, иначе вы пропустите строки.

Cells(xRg(K).row,1).Resize(,26).Copy Destination:=Worksheets("Change Log").Range("A" & J)
1
SJR 2 Янв 2018 в 14:44