EXCEL VBA，插入空白行并移动单元格
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/15816883/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
EXCEL VBA, inserting blank row and shifting cells
提问by ProjectPokket
I'm having trouble entering an entire blank row. I'm trying to shift Columns A-AD (four columns past Z).
我在输入整个空白行时遇到问题。我正在尝试移动 A-AD 列（经过 Z 的四列）。
Currently cells A-O has content. Cells O-AD are blank. But I'm running a macro to put data to the right of the current data (column O).
目前细胞AO有内容。单元格 O-AD 是空白的。但是我正在运行一个宏来将数据放在当前数据的右侧（O 列）。
I can insert a row using
我可以使用插入一行
dfind1.Offset(1).EntireRow.Insert shift:=xlDown
but it only seems to shift down from A-O. I've manage to shift down O-AD using a for loop
但它似乎只是从 AO 向下移动。我已经设法使用 for 循环向下移动 O-AD
dfind1 as Range
For d = 1 To 15
dfind1.Offset(2, (d + 14)).Insert shift:=xlDown
Next d
Is there a way to shift down 30 cells VS 15? Similarly, I want to shift 15 to the cells to the right. Currently I have another for loop setup for that.
有没有办法向下移动 30 个单元格 VS 15 个？同样，我想将 15 移到右侧的单元格。目前我有另一个 for 循环设置。
As for the rest of the code, its below. Basically merging two excel sheets bases on finding a match in column A. I've marked the problem area. The rest of the code works for the most part.
至于其余的代码，它在下面。基本上是基于在 A 列中找到匹配项来合并两个 Excel 表。我已经标记了问题区域。其余的代码大部分都有效。
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
回答by Gaussian Blur
If you want to just shift everything down you can use:
如果您只想将所有内容向下移动，您可以使用：
Rows(1).Insert shift:=xlShiftDown
Similarly to shift everything over:
同样将所有内容都转移过来：
Columns(1).Insert shift:=xlShiftRight
回答by ko_00
Sub Addrisk()
Dim rActive As Range
Dim Count_Id_Column as long
Set rActive = ActiveCell
Application.ScreenUpdating = False
with thisworkbook.sheets(1) 'change to "sheetname" or sheetindex
for i = 1 to .range("A1045783").end(xlup).row
if 'something' = 'something' then
.range("A" & i).EntireRow.Copy 'add thisworkbook.sheets(index_of_sheet) if you copy from another sheet
.range("A" & i).entirerow.insert shift:= xldown 'insert and shift down, can also use xlup
.range("A" & i + 1).EntireRow.paste 'paste is all, all other defs are less.
'change I to move on to next row (will get + 1 end of iteration)
i = i + 1
end if
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End With
next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True 're-enable screen updates
End Sub
