После удаления целых строк вновь скопированные данные сдвигаются вниз на x строк

Question

Прежде чем скопировать новый набор данных в набор столбцов, я хочу удалить все, кроме заголовков, что я делаю, используя следующий код:
wsS.Rows ( "4: 1048560") EntireRow.Delete

.

Я делаю это так, потому что данные распределяются по столбцам от A до AZ, и длина строк не совпадает.

Но каким-то образом команда покидает ячейки, которые ранее содержали данные и теперь выбраны пустыми, но только для столбцов от A до F (у меня есть 9 блоков данных, которые копируются, и для каждого блока я использовал разные sub (), которые позже вызывается внутри кнопки). Я также применяю фильтр на листе, с которого копирую данные.

Моя проблема в том, что новая копия каким-то образом начинается там, где должны были закончиться другие данные. Чем больше я запускаю код, тем больше строк запускается. Код для копирования был предложен кем-то здесь, и я лишь слегка адаптировал его под свои нужды.

Странная вещь заключается в том, что если я запустил приведенную выше команду удаления в «Немедленном окне» (или произвел ручное удаление), а затем снова запустил полный код, скопированные данные начнутся, как и должно быть в ячейке A4.

Я также пытался сделать выборку в ячейке A4 после удаления, а затем скопировать новые данные. Все еще безуспешно. И это происходит только для первого набора данных, который я копирую (столбцы от A до F) -> я использовал тот же код для копирования большего количества диапазонов (от A до F, от H до M, от O до T и т. Д.)

Это код для одного блока, а именно от A до F:

Private Sub CopyDataAtoF()
Dim wsR As Worksheet:       Set wsR = ThisWorkbook.Worksheets("Data Raw")
Dim wsS As Worksheet:       Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
Dim lrR As Long:            lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row
Dim lrS1 As Long:           lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1
Dim lrS2 As Long:           lrS2 = wsS.Cells(wsS.Rows.count, "C").End(xlUp).Row + 1
Dim lrS3 As Long:           lrS3 = wsS.Cells(wsS.Rows.count, "E").End(xlUp).Row + 1

With wsR
    Dim fRng As Range:      Set fRng = .Range(.Cells(1, "A"), .Cells(lrR, "AN"))
    Dim rngN As Range:      Set rngN = .Range(.Cells(2, "N"), .Cells(lrR, "N"))
    Dim rngY As Range:      Set rngY = .Range(.Cells(2, "Y"), .Cells(lrR, "Y"))
    Dim cRng As Range:      Set cRng = Union(rngN, rngY)
End With

Application.ScreenUpdating = False
wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp

fRng.AutoFilter field:=25, Criteria1:="<>", Operator:=xlFilterValues
fRng.AutoFilter field:=1, Criteria1:="criteria1", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
    cRng.Copy
    wsS.Cells(lrS1, "A").PasteSpecial xlPasteValues
    With wsS
        Dim vis1 As Long:    vis1 = .Cells(.Rows.count, "A").End(xlUp).Row
        Dim lcS1 As Long:    lcS1 = .Cells(lrS1, "A").End(xlToRight).Column + 1
        Dim divA As Range:   Set divA = .Range(.Cells(lrS1, "A"), .Cells(vis1, "A"))
        Dim divY1 As Range:  Set divY1 = .Range(.Cells(lrS1, lcS1), .Cells(vis1, lcS1))

        divY1.Formula = "=" & .Cells(lrS1, 1).Address(RowAbsolute:=False) & " / 1000"
        divA.Value2 = divY1.Value2
        divY1.ClearContents
    End With
End If

fRng.AutoFilter field:=1, Criteria1:="criteria2", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
    cRng.Copy
    wsS.Cells(lrS2, "C").PasteSpecial xlPasteValues
    With wsS
        Dim vis2 As Long:    vis2 = .Cells(.Rows.count, "C").End(xlUp).Row
        Dim lcS2 As Long:    lcS2 = .Cells(lrS2, "C").End(xlToRight).Column + 1
        Dim divC As Range:   Set divC = .Range(.Cells(lrS2, "C"), .Cells(vis2, "C"))
        Dim divY2 As Range:  Set divY2 = .Range(.Cells(lrS2, lcS2), .Cells(vis2, lcS2))

        divY2.Formula = "=" & .Cells(lrS2, 3).Address(RowAbsolute:=False) & " / 1000"
        divC.Value2 = divY2.Value2
        divY2.ClearContents
    End With
End If

fRng.AutoFilter field:=1, Criteria1:="criteria3", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
    cRng.Copy
    wsS.Cells(lrS3, "E").PasteSpecial xlPasteValues
    With wsS
        Dim vis3 As Long:    vis3 = .Cells(.Rows.count, "E").End(xlUp).Row
        Dim lcS3 As Long:    lcS3 = .Cells(lrS3, "E").End(xlToRight).Column + 1
        Dim divE As Range:  Set divE = .Range(.Cells(lrS3, "E"), .Cells(vis3, "E"))
        Dim divY3 As Range:  Set divY3 = .Range(.Cells(lrS3, lcS3), .Cells(vis3, lcS3))

        divY3.Formula = "=" & .Cells(lrS3, 5).Address(RowAbsolute:=False) & " / 1000"
        divE.Value2 = divY3.Value2
        divY3.ClearContents
    End With
End If

wsS.Range("A1").Select
wsR.AutoFilter.ShowAllData
Application.ScreenUpdating = True
End Sub

Answer 1

Проблема, с которой вы столкнулись, связана с тем, что все переменные с префиксом lr хранят индекс (неизменно) из последняя строка , которая содержала данные, перед тем, как вы все удалите их.

Исходя из того, как написан код, при вставке новых данных он начинается с номера индекса, хранящегося в lr -s.

Решение состоит в том, чтобы пересчитать значение lr -s после удаления данных.

Замените верхнюю часть вашего кода измененными кодами ниже, и коды должны работать так, как вы ожидаете.

Private Sub CopyDataAtoF()
Dim wsR As Worksheet:       Set wsR = ThisWorkbook.Worksheets("Data Raw")
Dim wsS As Worksheet:       Set wsS = ThisWorkbook.Worksheets("Scatter Raw")

Application.ScreenUpdating = False
wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp

Dim lrR As Long:            lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row
Dim lrS1 As Long:           lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1
Dim lrS2 As Long:           lrS2 = wsS.Cells(wsS.Rows.count, "C").End(xlUp).Row + 1
Dim lrS3 As Long:           lrS3 = wsS.Cells(wsS.Rows.count, "E").End(xlUp).Row + 1

With wsR
    Dim fRng As Range:      Set fRng = .Range(.Cells(1, "A"), .Cells(lrR, "AN"))
    Dim rngN As Range:      Set rngN = .Range(.Cells(2, "N"), .Cells(lrR, "N"))
    Dim rngY As Range:      Set rngY = .Range(.Cells(2, "Y"), .Cells(lrR, "Y"))
    Dim cRng As Range:      Set cRng = Union(rngN, rngY)
End With

fRng.AutoFilter field:=25, Criteria1:="<>", Operator:=xlFilterValues
fRng.AutoFilter field:=1, Criteria1:="criteria1", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then

Изменения, которые я сделал в коде, должны были переместиться;

 Application.ScreenUpdating = False
 wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp

выше;

Dim lrR As Long:            lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row
Dim lrS1 As Long:           lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1
        ...                               ...       

т.е. После удаления необходимых строк определяются и вычисляются lr.

Спасибо.