Code:' https://pastebin.com/nVaPWF5U Rem 3' FormatOriginForNewCells:= , optional parameter argumant for "Shift Method" Format origin Copy origin for Formats ( where does the Format come from ) ' https://pastebin.com/nVaPWF5U '3a) Determine users preference Dim Q_FrmatFrmUpOrleft As Long ' take this in from two similar Msgboxes If Q_ShftDown = vbYes Then ' We are shifting down, so next choice is format from above or below Let Q_FrmatFrmUpOrleft = MsgBox(prompt:="New range Format from above? ( Answer Yes for above or No for from below )", Buttons:=vbYesNo, Title:="use foramt from above/left or below/right") ' vbYes 6 vbNo 7 Else ' We are shifting right , so next choice is format from right or left Let Q_FrmatFrmUpOrleft = MsgBox(prompt:="New range Format from left ? ( Answer Yes left or No for right)", Buttons:=vbYesNo, Title:="use foramt from above/left or below/right") ' vbYes 6 vbNo 7 End If Dim FormatCopyOrigin As Long: Let FormatCopyOrigin = 0: ' Default: xlFormatFromLeftOrAbove or 0: Newly-inserted cells take the formatting from cells above or to the left. If Q_FrmatFrmUpOrleft = 7 Then Let FormatCopyOrigin = 1 ' 7 is vbNo xlFormatFromRightOrBelow or 1: Newly-inserted cells take formatting from cells below or to the right '3b) Determine Full Copy range for Formats If InsertShiftDirectionEnum = -4121 Then ' xlShiftDown -4121 Cells were shifted down Dim rngCopyOriginFullRwoffset As Long, rngCopyOriginFullClmoffset As Long: Let rngCopyOriginFullRwoffset = 0: Let rngCopyOriginFullClmoffset = 0 ' To be used to determine navigation vectors to Top Left of Range to Copy to get Formats If FormatCopyOrigin = 0 Then ' user has shifted down and wants to take format from above, we need to determine rngCopyOriginFullRwoffset which will be negative Let rngCopyOriginFullRwoffset = -1 * rngNewAttemptAndShift.Rows.Count ' This will take us back up to a Top left one rngNewAttemptAndShift Area back up Else ' user has shifted down and wants to take format from below Let rngCopyOriginFullRwoffset = rngNewAttemptAndShift.Rows.Count ' this will take the Top left one rngNewAttemptAndShift down End If Else ' InsertShiftDirectionEnum = -4161 ' cells were Shift To the Right If FormatCopyOrigin = 0 Then ' user has shifted right and wants to take format from left, we need to determine rngCopyOriginFullClmoffset which wil be negative Let rngCopyOriginFullClmoffset = -1 * rngNewAttemptAndShift.Columns.Count ' This will take us back left to a Top left one rngNewAttemptAndShift Area to the left Else ' user has shifted right and wants to take format from across to the right Let rngCopyOriginFullClmoffset = rngNewAttemptAndShift.Columns.Count ' this will take the Top left one rngNewAttemptAndShift across to the right End If End If ' End determining which direction cells were shifted to make space for new cells Dim rngCopyOriginFull As Range ' from where range should be copied to get formats for new range Set rngCopyOriginFull = Application.Range("" & refNewRngAreaAttempt & "").Offset(rngCopyOriginFullRwoffset, rngCopyOriginFullClmoffset) ' This should be the complete range from which to copy Formats ' Copy range rngCopyOrigin Then change it to get just the single width nearest range, then paste in a special way across the full New range , that is to say only formats rngCopyOriginFull.Copy ' Range.Copy method fills the clipboard with many links to the range I expect so that all aboout it can be got Application.Wait (Now + TimeValue("0:00:03")) ' Pause to show full selected range '3c) Determine first perimeter single width.... For the case of a multi row new Insert Area for a down shift , only the format of the first row is used. For a multi column Insert Area for a right shift, only the format of the first column is used Dim rngCopyOrigin As Range ' This will eventually be a reduced size of the rngCopyOriginFull _For : ... _For the case of a multi row new Insert Area for a down shift , only the format of the first row is used; ... _For a multi column Insert Area for a right shift, as only the format of the first column is used Set rngCopyOrigin = rngCopyOriginFull If InsertShiftDirectionEnum = -4121 Then ' xlShiftDown -4121 Cells were shifted down If FormatCopyOrigin = 0 Then ' user has shifted down and wants to take format from above, we need to resize the rngCopyOrigin to a single row and offset it by the rows count -1 to bring it to the last row in the Copy range Set rngCopyOrigin = rngCopyOrigin.Offset(rngCopyOrigin.Rows.Count - 1, 0).Resize(1) ' Offset first, we lose the row count for the resize, No place holder comma , is required when the final dimension is not resized Else ' user has shifted down and wants to take format from below, we only need to resize to 1 row Set rngCopyOrigin = rngCopyOrigin.Resize(1) End If Else ' InsertShiftDirectionEnum = -4161 ' cells were Shift To the Right If FormatCopyOrigin = 0 Then ' user has shifted right and wants to take format from left, we need to Offset by the columns count -1, then resize to 1 column Set rngCopyOrigin = rngCopyOrigin.Offset(0, rngCopyOrigin.Columns.Count - 1).Resize(, 1) Else ' user has shifted right and wants to take format from across to the right so we only need to resize copy range to 1 column Set rngCopyOrigin = rngCopyOrigin.Resize(, 1) End If End If ' End determining which direction cells were shifted to make space for new cells rngCopyOrigin.Copy ' copy the 1 perimeter width range Application.Wait (Now + TimeValue("0:00:03")) ' Pause to show the selected the 1 perimeter width range Application.Range("" & refNewRngAreaAttempt & "").PasteSpecial Paste:=xlPasteFormats Rem 4 Final "black box" code line using all parameters MsgBox prompt:="The previously done will all be ""deleted"", then the same will be done using the one line VBA Range.Insert" '4a)(Determine direction to shift back, then use Range.Delete method to return to the original situation Application.Wait (Now + TimeValue("0:00:01")) Dim DeleteShiftDirectionEnum As Long ' get the corrsponding "reverse" direction to the used InsertShift direction Select Case InsertShiftDirectionEnum Case -4121: Let DeleteShiftDirectionEnum = -4162 ' xlShiftDown -4121 -- xlShiftUp -4162 Zellen werden nach oben verschoben. XlDeleteShiftDirection Enumeration xlShiftUp -4162 Cells are shifted up. https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-delete-method-excel Case -4161: Let DeleteShiftDirectionEnum = -4159 ' xlShiftToRight -4161 -- xlShiftToLeft -4159 Zellen werden nach links verschoben. XlDeleteShiftDirection Enumeration xlShiftToLeft -4159 Cells are shifted to the left End Select 'Dim arrVls() As Variant: Let arrVls() = rngNewAttemptAndShift.Value ' the .Value Property returns a Field of variant types with the values of the range to which it is applied. Note thes values may be Empty, Values, Formulas Application.Range("" & refNewRngAreaAttempt & "").Delete Shift:=DeleteShiftDirectionEnum ' This I find good Hierarchical Object Orientated Programming syntaxly correct approach 'Let Application.Range("" & refNewRngAreaAttempt & "").Value = arrVls() ' We may assign the values of an Array directly to a spreadsheet range MsgBox prompt:="Finally, the standard code line will be used, based on your given options" Rem 4 Final "black box" code line using all parameters ... Application.Wait (Now + TimeValue("0:00:01")) ' Short pause, then all the above will be repated with the standard Range.Insert code line Application.Range("" & refNewRngAreaAttempt & "").Insert Shift:=InsertShiftDirectionEnum, CopyOrigin:=FormatCopyOrigin ' https://powerspreadsheets.com/excel-vba-insert-row/#Insert-Rows-with-the-RangeInsert-Method MsgBox prompt:="You would use the standard code line Range.Insert Shift:=__ ,CopyOrigin:=__ " & vbCrLf & "as follows(all as one line): " & vbCrLf & "Range(""" & refNewRngAreaAttempt & """)" & ".Insert Shift:=" & VBA.Strings.Left$(dicLookupTableMSRD.Item(InsertShiftDirectionEnum), VBA.Strings.InStr(1, dicLookupTableMSRD.Item(InsertShiftDirectionEnum), " ", vbTextCompare)) & ", CopyOrigin:=" & VBA.Strings.Left$(dicLookupTableMSRD.Item(FormatCopyOrigin), VBA.Strings.InStr(1, dicLookupTableMSRD.Item(FormatCopyOrigin), " ", vbTextCompare)) & "", Title:="Application.Range Full version Range.Insert code line" MsgBox prompt:="Simplified for Active Worksheet," & vbCrLf & "Copy following(all to one line): " & vbCrLf & "Range(""" & Replace(VBA.Strings.Mid$(refNewRngAreaAttempt, (VBA.Strings.InStr(1, refNewRngAreaAttempt, "!", vbTextCompare) + 1)), "$", "", 1, -1, vbTextCompare) & """).Insert Shift:=" & VBA.Strings.Left$(dicLookupTableMSRD.Item(InsertShiftDirectionEnum), VBA.Strings.InStr(1, dicLookupTableMSRD.Item(InsertShiftDirectionEnum), " ", vbTextCompare)) & ", CopyOrigin:=" & VBA.Strings.Left$(dicLookupTableMSRD.Item(FormatCopyOrigin), VBA.Strings.InStr(1, dicLookupTableMSRD.Item(FormatCopyOrigin), " ", vbTextCompare)) & "", Title:="The below, (all on one line), is the final standard code line" Debug.Print "Range(""" & Replace(VBA.Strings.Mid$(refNewRngAreaAttempt, (VBA.Strings.InStr(1, refNewRngAreaAttempt, "!", vbTextCompare) + 1)), "$", "", 1, -1, vbTextCompare) & """).Insert Shift:=" & VBA.Strings.Left$(dicLookupTableMSRD.Item(InsertShiftDirectionEnum), VBA.Strings.InStr(1, dicLookupTableMSRD.Item(InsertShiftDirectionEnum), " ", vbTextCompare) - 1) & ", CopyOrigin:=" & VBA.Strings.Left$(dicLookupTableMSRD.Item(FormatCopyOrigin), VBA.Strings.InStr(1, dicLookupTableMSRD.Item(FormatCopyOrigin), " ", vbTextCompare)) & "" End Sub
Bookmarks