EXCEL VBA, wstawiając puste wiersze i zmieniające się komórki

Question

Mam problem z wpisaniem całego pustego wiersza. Próbuję przenieść kolumny A-AD (cztery kolumny za Z).

Obecnie komórki A-O ma treść. Komórki O-AD są puste. Ale używam makra, aby umieścić dane po prawej stronie bieżących danych (kolumna O).

można wstawić rzędu przez

dfind1.Offset(1).EntireRow.Insert shift:=xlDown 

ale wydaje się jedynie przesuwać w dół od A-O. Udało mi się przesunąć O-AD za pomocą pętli for:

dfind1 as Range 
For d = 1 To 15 
    dfind1.Offset(2, (d + 14)).Insert shift:=xlDown 
Next d 

Czy istnieje sposób na przesunięcie w dół 30 komórek VS 15? Podobnie, chcę przesunąć 15 do komórek po prawej stronie. Obecnie mam do tego inną konfigurację pętli.

Co do reszty kodu, poniżej. Zasadniczo połączenie dwóch arkuszy programu Excel bazuje na znalezieniu dopasowania w kolumnie A. Zaznaczono obszar problemu. Reszta kodu działa w przeważającej części.

Sub combiner() 

    Dim c As Range, d As Long, cfind As Range, x, y, zed, dest As Range, cfind1 As Range, dfind As Range, _ 
    dfind1 As Range, crow, x_temp, y_temp 

    On Error Resume Next 
    Worksheets("sheet3").Cells.Clear 
    With Worksheets("sheet1") 
    .UsedRange.Copy Worksheets("sheet3").Range("a1") 
    End With 

    With Worksheets("sheet2") 
    For Each c In Range(.Range("a3"), .Range("a3").End(xlDown)) 
    x = c.Value 
    y = c.Next 

    Set cfind = .Cells.Find(what:=y, lookat:=xlWhole) 
    .Range(cfind.Offset(0, -1), cfind.End(xlToRight)).Copy 

     With Worksheets("sheet3") 
      Set dfind1 = .Cells.Find(what:=x, lookat:=xlWhole) 
      If dfind1 Is Nothing Then GoTo copyrev 

      '************************************************************** 
      '************************************************************** 
      'This is the problem Area 
      'I'm basically having trouble inserting a blank row 
      dfind1.Offset(1).EntireRow.Insert shift:=xlDown 



      For d = 1 To 15 
       dfind1.Offset(1).Insert shift:=xlToRight 
      Next d 

      For d = 1 To 15 
       dfind1.Offset(2, (d + 14)).Insert shift:=xlDown 
      Next d 
      '************************************************************** 
      '************************************************************** 


     End With 'sheet3 
     GoTo nextstep 

    copyrev: 
     With Worksheets("sheet3") 
      x_temp = .Cells(Rows.Count, "A").End(xlUp).Row 
      y_temp = .Cells(Rows.Count, "P").End(xlUp).Row 
      If y_temp > x_temp Then GoTo lr_ed 
      lMaxRows = x_temp 
      GoTo lrcont 
    lr_ed: 
      lMaxRows = y_temp 
    lrcont: 
      .Range(("P" & lMaxRows + 1)).PasteSpecial 
      Worksheets("sheet2").Range(cfind.Offset(0, -1), cfind.Offset(0, 0)).Copy 
      .Range(("A" & lMaxRows + 1)).PasteSpecial 
     End With 'sheet3 


    nextstep: 
    Next 


    lngLast = Range("A" & Rows.Count).End(xlUp).Row 

    With Worksheets("Sheet3").Sort 
     .SortFields.Clear 
     .SortFields.Add Key:=Range("A1:A2" & lngLast), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 
     .SetRange Range("B3:Z" & lngLast) 
     .Header = xlYes 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .SortMethod = xlPinYin 
     .Apply 
    End With 


    End With 'sheet2 
     Application.CutCopyMode = False 
End Sub 

Answer 1

Jeśli chcesz po prostu przenieść wszystko w dół można użyć:

Rows(1).Insert shift:=xlShiftDown 

Podobnie przesunąć wszystko nad:

Columns(1).Insert shift:=xlShiftRight