Почему сценарий VBA не копирует/перемещает записи в следующую пустую строку?

Я реализовал функцию в VBA со следующими целями:

  • Скопируйте значения из диапазона (A8:F400) на вкладке «Один столбец» в столбцы (AA2:AF) на вкладке «Индекс».
  • Критерии копирования записей из «Одного столбца», если в столбце D есть значение (не нулевое).
  • После копирования указанных записей, соответствующих этому критерию, вставьте значения и числовые форматы, найдите первую доступную строку на вкладке «Индекс» и вставьте диапазон.

Текущая проблема: при запуске/выполнении сценария vba набор данных копируется в соответствующие столбцы, но вставляется в диапазон от 20 000 до 80 000 строк, что превышает тысячи пустых строк. Я пытался выполнить сценарий несколько раз, но вставка продолжает превышать все пустые ячейки и добавляет набор данных дальше на вкладку моего индексного листа.

Sub MoveListToIndex()

'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

    Dim Answer As VbMsgBoxResult
    
    Answer = MsgBox("Are you sure you want to Submit the List?", vbYesNo, "Submit List")
    
        If Answer = vbYes Then

Dim D As Range

Set D = Worksheets("Single Column").Range("D7:D400")

  'Set variables for copy and destination sheets
  Set wsCopy = Worksheets("Single Column")
  Set wsDest = Worksheets("Index")

For Each cell In D

If cell.Value <> "" Then

  '1. Find last used row in the copy range based on data in column D
  lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
    
  '2. Find first blank row in the destination range based on data in column AA
  'Offset property moves down 1 row
  lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "AA").End(xlUp).Offset(1).Row

  '3. Copy & Paste Data
  wsCopy.Range("A8:F400" & lCopyLastRow).Copy
  wsDest.Range("AA" & lDestLastRow).PasteSpecial xlPasteValuesAndNumberFormats

End If
Next cell

Application.ScreenUpdating = True
            MsgBox "The List has been Successfully Added!"
 
End If
End Sub

Фиктивная таблица


55
1

Ответ:

Решено

Вот альтернатива, которую можно попробовать:

Sub MoveListToIndex()

'Find the last used row in both sheets and copy and paste data below existing data.

Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

    Dim Answer As VbMsgBoxResult
    
    Answer = MsgBox("Are you sure you want to Submit the List?", vbYesNo, "Submit List")
    
        If Answer = vbYes Then

Dim D As Range

Set D = Worksheets("Single Column").Range("D7:D400")

  'Set variables for copy and destination sheets
  Set wsCopy = Worksheets("Single Column")
  Set wsDest = Worksheets("Index")

'1. Non-empty in D - header row + row to the first cell D7
lCopyLastRow = Application.WorksheetFunction.CountA(D) - 1 + 7
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "AA").End(xlUp).Offset(1).Row



  '2. Copy & Paste Data
  wsCopy.Range("A8:F" & lCopyLastRow).Copy
  wsDest.Range("AA" & lDestLastRow).PasteSpecial xlPasteValuesAndNumberFormats


'Debug.Print "A8:F" & lCopyLastRow

Application.ScreenUpdating = True
            MsgBox "The List has been Successfully Added!"
 
End If
End Sub