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
Reply With Quote
Bookmarks