Код VBA для перемещения столбцов только вновь вставленных строк данных

#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, чтобы проверить, работает ли это, но вы должны быть в состоянии понять суть моего предлагаемого решения из приведенного выше.