#excel #vba #copy
#excel #vba #Копировать
Вопрос:
Как показано в макете таблицы выше, я пытаюсь написать макрос, который копирует новые данные из другой рабочей книги (Other Workbook), а затем вставляет их под существующую базу данных (в ThisWorkbook).
После этого, только для новых вставленных строк данных, я хочу сдвинуть значения в столбцах A, B, C, D на одну ячейку вправо. Мой текущий код работает правильно до тех пор, пока он не должен перемещать столбцы, но затем появляется ошибка.
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim CopyLastRow As Long
Dim DestLastRow As Long
Dim ToCopy As Range
Dim ToPaste As Range
Set wsCopy = Workbooks("OtherWorkBook").Worksheets("OtherWorkSheet")
Set wsDest = Workbooks("ThisWorkBook").Worksheets("ThisWorkSheet")
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Row
DestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
wsCopy.Range("A2:V" amp; CopyLastRow).Copy _
wsDest.Range("A" amp; DestLastRow)
Set ToCopy = wsCopy.Range("A2:V" amp; CopyLastRow)
Set ToPaste = wsDest.Range("A" amp; PasteToLastRow)
ToCopy.Copy ToPaste
Set ToPaste = ToPaste.Resize(ToCopy.Rows.Count, ToCopy.Columns.Count)
ToPaste.Columns("A:D").Cut
'The debugger highlights this line of code
ToPaste.Columns("D").Insert Shift:=xlToRight
Запись макросов была бы невозможна, поскольку макрос периодически выполняется для добавления новых строк данных
Комментарии:
1. Пожалуйста, покажите код, который вы пытаетесь использовать. Одна вещь, которую вы захотите убедиться, что нет объединенных ячеек.
2. добавлено по запросу
3.
Range("E:E").ClearContents
затемRange(A:A).Insert
4. Я попробовал, но появляется тот же код ошибки
5. Это не может быть то же самое, что и при копировании вставки.
Ответ №1:
Вы говорите, что перемещаете значения, чтобы вы могли использовать Range.Value
, а не вырезать / вставлять
Sub Demo()
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim CopyLastRow As Long
Dim DestLastRow As Long
Dim ToCopy As Range
Dim ToPaste As Range
Set wsCopy = Workbooks("OtherWorkBook").Worksheets("OtherWorkSheet")
Set wsDest = Workbooks("ThisWorkBook").Worksheets("ThisWorkSheet")
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Row
DestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
' deleted redundant Copy/Paste here
Set ToCopy = wsCopy.Range("A2:V" amp; CopyLastRow)
Set ToPaste = wsDest.Range("A" amp; PasteToLastRow)
' copy the data
ToCopy.Copy ToPaste
' Resize ToPaste to the pasted rows, 4 columns
Set ToPaste = ToPaste.Resize(ToCopy.Rows.Count, 4)
' Move first 4 columns 1 column to right, leave formatting intact
ToPaste.Offset(, 1).Value = ToPaste.Value
' Clear the first column
ToPaste.Columns(1).ClearContents
End Sub
Ответ №2:
Попробуйте выполнить следующее:
Columns("D").Cut
Columns("E").Insert Shift:=xlToRight
Columns("C").Cut
Columns("D").Insert Shift:=xlToRight
Columns("B").Cut
Columns("C").Insert Shift:=xlToRight
Columns("A").Cut
Columns("B").Insert Shift:=xlToRight
К сожалению, у меня нет компьютера Microsoft Office, чтобы проверить, работает ли это, но вы должны быть в состоянии понять суть моего предлагаемого решения из приведенного выше.
Комментарии:
1. я добавил больше строк кода в моей правке, которые могут быть причиной моей проблемы