Question

我编写了以下宏来执行以下操作：完成行 n 和 m 之间列表中的选择后，在选择上方插入行 m + 1 ，同时将选择向下移动1线。在这样做时，我想粘贴特殊公式和数字格式

Dim selbegin As Long, selend As Long
selbegin = Selection.Rows(1).Row
selend = Selection.Rows.Count + selbegin - 1
Sheets("overview").Range("A" & selbegin, "DM" & selend).Copy
Sheets("buffer").Visible = True
Sheets("buffer").Range("A1").PasteSpecial Paste:=xlPasteFormulas
Sheets("buffer").Range("A1").PasteSpecial Paste:=xlPasteFormats
Sheets("overview").Rows(selend + 1).Copy
Sheets("overview").Rows(selbegin).PasteSpecial Paste:=xlPasteFormulas
Sheets("overview").Rows(selbegin).PasteSpecial Paste:=xlPasteFormats
Sheets("buffer").Range("A1", "DM" & selend).Copy
Sheets("overview").Range("A" & selbegin + 1, _
"DM" & selend + 1).PasteSpecial Paste:=xlPasteFormulas
Sheets("Diag. readiness overview").Range("A" & selbegin + 1, _
"DM" & selend + 1).PasteSpecial Paste:=xlPasteFormats
Sheets("buffer").Visible = 2
Sheets("buffer").UsedRange.ClearContents
MsgBox "moving completed"

复制到缓冲区页面会丢失公式中的引用，然后从缓冲区到概述的pastespecial会失败。有没有办法在不使用缓冲区的情况下做同样的事情？

编辑：

我将代码更改为此

Dim selbegin As Long, selend As Long, lastrow As Long
selbegin = Selection.Rows(1).Row
selend = Selection.Rows.Count + selbegin - 1
lastrow = ActiveSheet.Cells(1000, 1).End(xlUp).Row
If lastrow < selend Then
    MsgBox "it's not possible to move an empty selection."
    Exit Sub
End If
'first create an empty line by shifting down by 1 row _
all the rows from the beginning of the selection
ActiveSheet.Range("A" & selbegin, "DM" & lastrow).Copy
ActiveSheet.Range("A" & selbegin + 1, "DM" & lastrow + 1)._
PasteSpecial Paste:=xlPastefFormulas
ActiveSheet.Range("A" & selbegin + 1, "DM" & lastrow + 1)._
PasteSpecial Paste:=xlPastefFormats
'then move the first row after the selection to the empty row
ActiveSheet.Range("A" & selend + 2).Copy
ActiveSheet.Range("A" & selbegin).PasteSpecial Paste:=xlPasteFormulas
ActiveSheet.Range("A" & selbegin).PasteSpecial Paste:=xlPasteFormats
'then move up 1 line the rows below the selection
ActiveSheet.Range("A" & selend + 3, "DM" & lastrow + 1).Copy
ActiveSheet.Range("A" & selend + 2, "DM" & lastrow).PasteSpecial Paste:=xlPasteFormulas
ActiveSheet.Range("A" & selend + 2, "DM" & lastrow).PasteSpecial Paste:=xlPasteFormats
'inform the user moving is complete
MsgBox "moving completed"

现在我得到paste special method of Range class failed和xlsPasteFormats = -4122

Answer 1

此代码符合我的目的

'rearrange lines based on selection, moving the line below the selection_
to the line above the selection and shifting the selection down 1 line
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim selbegin As Long, selend As Long, lastrow As Long
selbegin = Selection.Rows(1).Row
selend = Selection.Rows.Count + selbegin - 1
lastrow = ActiveSheet.Cells(1000, 1).End(xlUp).Row
If lastrow < selend Then
    MsgBox "it's not possible to move an empty selection. please select filled in lines"
    Exit Sub
End If
If lastrow = selend Then
    MsgBox "to move the last line, select till the last but one"
    Exit Sub
End If
If lastrow > 999 Then
    MsgBox "it's not possible to move the last line"
End If

'first create an empty line by shifting down by 1 row all the rows from the beginning_
of the selection
ActiveSheet.Range("A" & selbegin, "DM" & lastrow).Copy
ActiveSheet.Range("A" & selbegin + 1, "DM" & lastrow + 1).PasteSpecial_
Paste:=xlPasteFormulas

'then move the first row after the selection to the empty row
ActiveSheet.Range("A" & selend + 2, "DM" & selend + 2).Copy
ActiveSheet.Range("A" & selbegin, "DM" & selbegin).PasteSpecial Paste:=xlPasteFormulas

'then move up 1 line the rows below the selection
If lastrow - selend > 1 Then
    ActiveSheet.Range("A" & selend + 3, "DM" & lastrow + 1).Copy
    ActiveSheet.Range("A" & selend + 2, "DM" & lastrow).PasteSpecial_
Paste:=xlPasteFormulas
End If

'clear the last row
On Error Resume Next
ActiveSheet.Range("A" & lastrow + 1, "DM" & lastrow + 1).SpecialCells_
(xlCellTypeConstants).ClearContents

'restore formulas
ActiveSheet.Range("A" & selend + 2, "DM" & selend + 2).Copy
ActiveSheet.Range("A" & lastrow + 1, "DM" & lastrow + 1).PasteSpecial_
Paste:=xlPasteFormats
'restore dashes where needed
For Column = 14 To 65
    If Cells(lastrow + 2, Column) = "-" Then
        Cells(lastrow + 1, Column) = "-"
    End If
Next Column
Application.CutCopyMode = False
Range("A" & selbegin).Select
'inform the user moving is complete
'MsgBox "moving completed"
Application.ScreenUpdating = True
Application.EnableEvents = True

用于重新排列行的宏，同时保留公式和格式

1 个答案: