宏重新安排行，同時保留公式和格式

我寫了下面的宏做到以下幾點：一次選擇行ñ和米之間的列表完成後，插入行米+ 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

來源

2016-04-29 L.Dutch

此代碼擔任我的目的

'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

來源

2016-05-02 06:50:10

宏重新安排行，同時保留公式和格式

回答

相關問題