вырезать копировать вставить петлю инструкцию между двумя листами

Question

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

Таким образом, у меня есть диапазон A12: N112, который нужно отсортировать в строке A с убывающими значениями.

Далее мне нужно скопировать каждую строку (B: L), где в столбце A есть «1», и вставить ее в первую пустую строку в другой книге, поскольку столбец D пуст. Затем мне нужно скопировать число, сгенерированное в столбце A, для строки, в которую я только что вставил, а затем вставить ее обратно в исходную строку, скопированную в строке N первой электронной таблицы.

Мне нужно это затем зациклить, пока мы не достигнем первого значения «0» в первой электронной таблице.

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

Dim r As Long
Dim lr As Long
Dim wkb As Workbook
Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet

Set wkb = ThisWorkbook
Set ws = wkb.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srveurfcl03.nov.com\IS-GBR-GLBISETNRegister$\Serial No Trial\Serialisation Log.xlsx")
Set ws2 = wkb2.Worksheets("SNo Log")

wkb.Activate
ws.Activate
ActiveWorkbook.Worksheets("Data Entry").sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data Entry").sort.SortFields.Add Key:=Range( _
    "A12:A112"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Data Entry").sort
   .SetRange Range("A11:N112")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

For r = 12 To lr
If wkb.ws.Cells(r, 1).Value = 1 Then
    ws.Cells(r, "B:L").Copy

    wkb2.Activate
    ws2.Activate
    Range("D" & Rows.Count).EndX(x1Up).Offset(1).Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    Range("A" & Rows.Count).End(xlUp).Offset(0).Select
    Selection.Copy
    wkb.Activate
    ws.Cells(r, 13).Value.Paste
End If
If wkb.ws.Cells(r, 1).Value = 0 Then
   ws.Cells(4, 9).Select
   ActiveCell.FormulaR1C1 = "Serial No. Issue complete for this OA"
End If
Range("F5").Select
Next r

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

Answer 1

Согласно моим комментариям, вам не нужно сортировать данные или использовать Activate. Использование Range("D" & Rows.Count).EndX(x1Up).Offset(1) шло в правильном направлении, за исключением того, что вам нужно было удалить X в EndX. Кроме того, часть кода ниже не имеет никакого смысла. Поэтому вам нужно уточнить, что вы хотите, и, если нужно, включить пример результата.

    Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste
    Range("A" & Rows.Count).End(xlUp).Offset(0).Select
    Selection.Copy
    wkb.Activate
    ws.Cells(r, 13).Value.Paste
End If
If wkb.ws.Cells(r, 1).Value = 0 Then
   ws.Cells(4, 9).Select
   ActiveCell.FormulaR1C1 = "Serial No. Issue complete for this OA"
End If
Range("F5").Select

Лучший способ скопировать диапазон - это скопировать весь диапазон, а не построчно. Приведенный ниже код скроет все строки из Range("A12:A112"), которые не имеют «1» в столбце A. Затем он скопирует видимые ячейки в диапазоне, используя SpecialCells(xlCellTypeVisible), и вставит их в первую пустую ячейку в ws2.Column(4). Затем все строки, которые были скрыты, снова становятся видимыми Этот код будет работать, если переменные вашей рабочей книги и рабочей таблицы верны.

Dim ws As Worksheet
Dim wkb2 As Workbook
Dim ws2 As Worksheet
Dim Rng As Range

Set ws = ThisWorkbook.Worksheets("Data Entry")
Set wkb2 = Workbooks.Open("\\srveurfcl03.nov.com\IS-GBR-GLBISETNRegister$\Serial No Trial\Serialisation Log.xlsx")
Set ws2 = wkb2.Worksheets("SNo Log")

    For Each cell In ws.Range("A12:A112")
        If cell.Value <> "1" Then
            cell.EntireRow.Hidden = True
        End If
    Next cell

    Set Rng = ws.Range("A12:A112").SpecialCells(xlCellTypeVisible)
        Rng.Copy Destination:=ws2.Cells(Rows.Count, 4).End(xlUp).Offset(1)

    ws.Range("A12:A112").EntireRow.Hidden = False