Create a new version of paste:

New Paste
Syntax Highlighting
 ' https://www.excelforum.com/development-testing-forum/1154829-collection-stuff-of-codes-for-other-threads-no-reply-needed-11.html#post4555023    https://www.excelforum.com/development-testing-forum/1154829-collection-stuff-of-codes-for-other-threads-no-reply-needed-12.html#post4555457     https://www.excelforum.com/development-testing-forum/1154829-collection-stuff-of-codes-for-other-threads-no-reply-needed-12.html#post4561126     https://www.excelforum.com/tips-and-tutorials/1136702-vba-range-insert-method-excel-oop-syntax-error.html       https://testosteronesboosterweb.com/titan-blast/
Option Explicit
Dim rngCopy As Range, rngNew As Range
Dim dicLookupTableMSRD As Object
Sub MeOwl()  '        https://www.excelforum.com/development-testing-forum/1215283-gimmie-ta-codexamples-call-in-the-appendix-posts-2018-no-reply-needed-but-if-u.html#post4822550
' Arbritrary Test Range Clear and Refresh
Rows("1:20").Clear
Dim RngObj1Area As Range
 Set RngObj1Area = Range("B2:J10")
 Let RngObj1Area.Interior.Color = vbYellow
' List of Range.Insert parameter argument options
 Set dicLookupTableMSRD = CreateObject("Scripting.Dictionary") 'Late Binding MSRD   In this case Dictionary and Scripting.Dictionary are the same. You can be sure of that because removing the reference to the Scripting runtime makes the Dictionary code fail. When you declare a variable as Dictionary, the compiler will check the available references to locate the correct object. There is no native VBA.Dictionary incidentally, though it is of course possible to create your own class called Dictionary, which is why I used the phrase "in this case".    https://www.excelforum.com/excel-programming-vba-macros/1147313-dictionary-or-scripting-dictionary-binding-referencing-dim-ing-sub-routines-and-function.html#post4431231   http://www.eileenslounge.com/viewtopic.php?f=30&t=24955#p193413        https://www.excelforum.com/excel-programming-vba-macros/1135724-compare-and-find-missing-rows-in-two-sheets-with-different-headings-and-formats.html       http://advisorwellness.com/blue-fortera/
 Let dicLookupTableMSRD.CompareMode = vbTextCompare
 dicLookupTableMSRD.Add Key:=-4121, Item:="xlShiftDown or -4121: Shifts cells down." '  XlInsertShiftDirection   https://powerspreadsheets.com/excel-vba-insert-row/#Insert-Rows-with-the-RangeInsert-Method
 dicLookupTableMSRD.Add Key:=-4161, Item:="xlShiftToRight or -4161: Shifts cells to the right." '  XlInsertShiftDirection
 dicLookupTableMSRD.Add Key:=0, Item:="xlFormatFromLeftOrAbove or 0: Newly-inserted cells take formatting from cells above or to the left." '  Default .. xlInsertFormatOrigin Enumeration   https://powerspreadsheets.com/excel-vba-insert-row/#Insert-Rows-with-the-RangeInsert-Method
 dicLookupTableMSRD.Add Key:=1, Item:="xlFormatFromRightOrBelow or 1: Newly-inserted cells take formatting from cells below or to the right." '  xlInsertFormatOrigin Enumeration
 ' Range to be copied to Clipboard. CHANGE TO EXPERIMENT
 Set rngCopy = Range("D4:E5")
' Set rngCopy = Rows("4:5")
 Let rngCopy.Interior.Color = vbRed
' Function call to return Demo Array to paste out into a Worksheet to demonstrate the Range Property Item arguments for both the two and one argument case, with the two argument case demonstrating the option of using a column Letter for the second argument in that two argument option
 Let RngObj1Area.Value = RangeItemsArgumantsSHimpfGlified(RngObj1Area)
 Columns("B:J").AutoFit
End Sub
'  Simplified one Liner Function
Public Function RangeItemsArgumantsSHimpfGlified(RngOrg As Range) As Variant
 Let RangeItemsArgumantsSHimpfGlified = Evaluate("=" & """RngItm(""" & "&" & "(Row(" & RngOrg.Address & ")" & "-" & "Row(" & RngOrg.Item(1).Address & ")" & ")+1&" & """, """"""" & "&" & "MID(ADDRESS(1,COLUMN(" & RngOrg.Address & ")-COLUMN(" & RngOrg.Item(1).Address & ")+1),2,(FIND(""$"",ADDRESS(1,COLUMN(" & RngOrg.Address & ")-COLUMN(" & RngOrg.Item(1).Address & ")+1),2)-2))" & "&" & """"""") &(""" & "&" & "(Column(" & RngOrg.Address & ")-Column(" & RngOrg.Item(1).Address & "))+1+" & "(((Row(" & RngOrg.Address & ")" & "-" & "Row(" & RngOrg.Item(1).Address & ")" & ")+1-1)*" & RngOrg.Columns.Count & ")" & "&" & """)""")
End Function

'     '    https://www.excelforum.com/development-testing-forum/1215283-gimmie-ta-codexamples-call-in-the-appendix-posts-2018-no-reply-needed-but-if-u.html#post4822823
Sub SpreadApartSlipInGetColoured() ' https://powerspreadsheets.com/excel-vba-insert-row/#Insert-Rows-with-the-RangeInsert-Method  https://www.excelforum.com/development-testing-forum/1215283-gimmie-ta-codexamples-call-in-the-appendix-posts-2018-no-reply-needed-but-if-u.html#post4822550
Rem -1
 Call MeOwl: Application.Wait (Now + TimeValue("0:00:02")) ' Run code  Sub  MeOwl initially to get a simple test range. Yellow is intended to represent some arbitrary working range that you are interested in. ( The red range will be used later for the case of when something is in the clipboard ) Assume you are not too interested in anything a long way outside this range, so empty cells can "slip off" the edge of the worksheet when we shift cells to make a space, and we are not bothered about that. ( Note again: if you had things around the right and bottom perimeters then the VBA Range.Insert Code line might not work in order to prevent anything you have slipping of the edge in a shift action )
 Let Application.CutCopyMode = False ' Strange things can happen if there is something in the clipboard:
' -1(ii) get some convenient strings for later use
Rem 0' Adjust slightly the demo range for this simple nothing in clipboard case.
 Let rngCopy.Interior.Color = vbYellow: Let Application.CutCopyMode = False ' In this code we are not interseted in investigating effects of doing a Copy before using the "...Range.Insert Method Code line makes a space to put new range in...."
Rem 1' "Shift Method"    "Property Direction" "Direction:="
Dim Q_ShftDown As Long: Let Q_ShftDown = MsgBox(prompt:="Shift Down ?( Answer Yes to shift down or No to spread cells to the right)", Buttons:=vbYesNo, Title:="Shift/ Spread/ Move Spreadsheet cells to Add new range") ' vbYes 6   vbNo 7
Dim InsertShiftDirectionEnum As Long: Let InsertShiftDirectionEnum = -4161 ' xlShiftToRight -4161 Zellen nach rechts verschieben
    If Q_ShftDown = 6 Then Let InsertShiftDirectionEnum = -4121 ' xlShiftDown -4121 Cells shift down  6 is vbYes
Rem 2' "Shift Method"    "Initial attempted size in spreadsheet to expose for new range"  "TrialRange:=" Property Area for attempted insert
Dim rngNewAttemptAndShift As Range ' Input box with option for range input is I use simply as it is convenient for a spreadsheet Range selection
 Set rngNewAttemptAndShift = Application.InputBox(prompt:="Select a range for insert attempt, then hit Enter or ""OK""", Title:="Posistion and size of space to make for new range. Insert Area attempt", Default:=Selection.Address, Type:=8)
Dim refNewRngAreaAttempt As String ' I am deliberately going a bit back and forth here to try to demonstrate a more logical approach to the thing in general. My thinking is that for the sake of convenience a more correct syntax logic was not done. In the places that  I use the actual  Range.Insert  in my code I tend to consider it as a "black box" code line.
 Let refNewRngAreaAttempt = "=" & "'" & rngNewAttemptAndShift.Parent.Parent.Path & "\" & "[" & rngNewAttemptAndShift.Parent.Parent.Name & "]" & rngNewAttemptAndShift.Parent.Name & "'" & "!" & rngNewAttemptAndShift.Address & "":  Debug.Print refNewRngAreaAttempt ' Ctrl+g to get debug Window to check this tricky format
 Set rngNewAttemptAndShift = Application.Range("" & refNewRngAreaAttempt & "")
 rngNewAttemptAndShift.Insert Shift:=InsertShiftDirectionEnum: Application.Range("" & refNewRngAreaAttempt & "").Clear ' This black box code line I use to achieve the point in the process just before the last argument condition is added.
 ' Note I cannot so this : rngNewAttemptAndShift.Clear  because rngNewAttemptAndShift is shifted also .. but this is convenient for the over next line '_-
'_- '2b) '4a)(i).... Just for Info...
Dim rngNewAttemptedAndShifted As Range: Set rngNewAttemptedAndShifted = rngNewAttemptAndShift
 rngNewAttemptedAndShifted.Select
 MsgBox prompt:="Note:....Just for Info... the range object that you selected..." & vbCrLf & "Now has Address " & rngNewAttemptedAndShifted.Address, Title:="Note: The address of your selected range also changed due to the shift!"
Rem 3' FormatOriginForNewCells:= , optional parameter argumant for "Shift Method"   Format origin Copy origin for Formats ( where does the Format come from )
'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
Optional Paste Settings
Category:
Tags:
Syntax Highlighting:
Paste Expiration:
Paste Exposure:
Folder:
PasswordNEW
Disabled
Burn after read NEW
Paste Name / Title:
Hello Guest
You are currently not logged in, this means you can not edit or delete anything you paste. Sign Up or Login