Я реализовал функцию в VBA со следующими целями:
Текущая проблема: при запуске/выполнении сценария 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
Вот альтернатива, которую можно попробовать:
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