Advertisement
AlanElston

Range.Insert

Jan 24th, 2018
450
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1.  ' 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/
  2. Option Explicit
  3. Dim rngCopy As Range, rngNew As Range
  4. Dim dicLookupTableMSRD As Object
  5. 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
  6. ' Arbritrary Test Range Clear and Refresh
  7. Rows("1:20").Clear
  8. Dim RngObj1Area As Range
  9.  Set RngObj1Area = Range("B2:J10")
  10.  Let RngObj1Area.Interior.Color = vbYellow
  11. ' List of Range.Insert parameter argument options
  12. 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/
  13. Let dicLookupTableMSRD.CompareMode = vbTextCompare
  14.  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
  15. dicLookupTableMSRD.Add Key:=-4161, Item:="xlShiftToRight or -4161: Shifts cells to the right." '  XlInsertShiftDirection
  16. 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
  17. dicLookupTableMSRD.Add Key:=1, Item:="xlFormatFromRightOrBelow or 1: Newly-inserted cells take formatting from cells below or to the right." '  xlInsertFormatOrigin Enumeration
  18. ' Range to be copied to Clipboard. CHANGE TO EXPERIMENT
  19. Set rngCopy = Range("D4:E5")
  20. ' Set rngCopy = Rows("4:5")
  21. Let rngCopy.Interior.Color = vbRed
  22. ' 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
  23. Let RngObj1Area.Value = RangeItemsArgumantsSHimpfGlified(RngObj1Area)
  24.  Columns("B:J").AutoFit
  25. End Sub
  26. '  Simplified one Liner Function
  27. Public Function RangeItemsArgumantsSHimpfGlified(RngOrg As Range) As Variant
  28.  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 & ")" & "&" & """)""")
  29. End Function
  30.  
  31. '     '    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
  32. 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
  33. Rem -1
  34.  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 )
  35. Let Application.CutCopyMode = False ' Strange things can happen if there is something in the clipboard:
  36. ' -1(ii) get some convenient strings for later use
  37. Rem 0' Adjust slightly the demo range for this simple nothing in clipboard case.
  38. 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...."
  39. Rem 1' "Shift Method"    "Property Direction" "Direction:="
  40. 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
  41. Dim InsertShiftDirectionEnum As Long: Let InsertShiftDirectionEnum = -4161 ' xlShiftToRight -4161 Zellen nach rechts verschieben
  42.    If Q_ShftDown = 6 Then Let InsertShiftDirectionEnum = -4121 ' xlShiftDown -4121 Cells shift down  6 is vbYes
  43. Rem 2' "Shift Method"    "Initial attempted size in spreadsheet to expose for new range"  "TrialRange:=" Property Area for attempted insert
  44. Dim rngNewAttemptAndShift As Range ' Input box with option for range input is I use simply as it is convenient for a spreadsheet Range selection
  45. 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)
  46. 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.
  47. 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
  48. Set rngNewAttemptAndShift = Application.Range("" & refNewRngAreaAttempt & "")
  49.  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.
  50. ' Note I cannot so this : rngNewAttemptAndShift.Clear  because rngNewAttemptAndShift is shifted also .. but this is convenient for the over next line '_-
  51. '_- '2b) '4a)(i).... Just for Info...
  52. Dim rngNewAttemptedAndShifted As Range: Set rngNewAttemptedAndShifted = rngNewAttemptAndShift
  53.  rngNewAttemptedAndShifted.Select
  54.  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!"
  55. Rem 3' FormatOriginForNewCells:= , optional parameter argumant for "Shift Method"   Format origin Copy origin for Formats ( where does the Format come from )
  56. '3a) Determine users preference
  57. Dim Q_FrmatFrmUpOrleft As Long ' take this in from two similar Msgboxes
  58.    If Q_ShftDown = vbYes Then ' We are shifting down, so next choice is format from above or below
  59.     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
  60.    Else                       ' We are shifting right , so next choice is format from right or left
  61.     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
  62.    End If
  63. Dim FormatCopyOrigin As Long: Let FormatCopyOrigin = 0: ' Default: xlFormatFromLeftOrAbove or 0:  Newly-inserted cells take the formatting from cells above or to the left.
  64.    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
  65. '3b) Determine Full Copy range for Formats
  66.    If InsertShiftDirectionEnum = -4121 Then ' xlShiftDown -4121 Cells were shifted down
  67.    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
  68.        If FormatCopyOrigin = 0 Then ' user has shifted down and wants to take format from above, we need to determine rngCopyOriginFullRwoffset which will be negative
  69.         Let rngCopyOriginFullRwoffset = -1 * rngNewAttemptAndShift.Rows.Count ' This will take us back up to a Top left one rngNewAttemptAndShift Area back up
  70.        Else ' user has shifted down and wants to take format from below
  71.         Let rngCopyOriginFullRwoffset = rngNewAttemptAndShift.Rows.Count ' this will take the Top left one rngNewAttemptAndShift down
  72.        End If
  73.     Else ' InsertShiftDirectionEnum = -4161 ' cells were Shift To the Right
  74.        If FormatCopyOrigin = 0 Then ' user has shifted right and wants to take format from left, we need to determine rngCopyOriginFullClmoffset which wil be negative
  75.         Let rngCopyOriginFullClmoffset = -1 * rngNewAttemptAndShift.Columns.Count ' This will take us back left to a Top left one rngNewAttemptAndShift Area to the left
  76.        Else ' user has shifted right and wants to take format from across to the right
  77.         Let rngCopyOriginFullClmoffset = rngNewAttemptAndShift.Columns.Count ' this will take the Top left one rngNewAttemptAndShift across to the right
  78.        End If
  79.     End If ' End determining which direction cells were shifted to make space for new cells
  80. Dim rngCopyOriginFull As Range ' from where range should be copied to get formats for new range
  81. Set rngCopyOriginFull = Application.Range("" & refNewRngAreaAttempt & "").Offset(rngCopyOriginFullRwoffset, rngCopyOriginFullClmoffset) ' This should be the complete range from which to copy Formats
  82. ' 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
  83. rngCopyOriginFull.Copy ' Range.Copy method fills the clipboard with many links to the range I expect so that all aboout it can be got
  84. Application.Wait (Now + TimeValue("0:00:03")) ' Pause to show full selected range
  85. '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
  86. 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
  87. Set rngCopyOrigin = rngCopyOriginFull
  88.     If InsertShiftDirectionEnum = -4121 Then ' xlShiftDown -4121 Cells were shifted down
  89.        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
  90.         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
  91.        Else ' user has shifted down and wants to take format from below, we only need to resize to 1 row
  92.         Set rngCopyOrigin = rngCopyOrigin.Resize(1)
  93.         End If
  94.     Else ' InsertShiftDirectionEnum = -4161 ' cells were Shift To the Right
  95.        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
  96.         Set rngCopyOrigin = rngCopyOrigin.Offset(0, rngCopyOrigin.Columns.Count - 1).Resize(, 1)
  97.         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
  98.         Set rngCopyOrigin = rngCopyOrigin.Resize(, 1)
  99.         End If
  100.     End If ' End determining which direction cells were shifted to make space for new cells
  101. rngCopyOrigin.Copy ' copy the 1 perimeter width range
  102. Application.Wait (Now + TimeValue("0:00:03")) ' Pause to show the selected the 1 perimeter width range
  103. Application.Range("" & refNewRngAreaAttempt & "").PasteSpecial Paste:=xlPasteFormats
  104. Rem 4 Final "black box" code line using all parameters
  105.  MsgBox prompt:="The previously done will all be ""deleted"", then the same will be done using the one line  VBA Range.Insert"
  106. '4a)(Determine direction to shift back, then use Range.Delete method to return to the original situation
  107. Application.Wait (Now + TimeValue("0:00:01"))
  108. Dim DeleteShiftDirectionEnum As Long ' get the corrsponding "reverse" direction to the used InsertShift direction
  109.    Select Case InsertShiftDirectionEnum
  110.      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
  111.     Case -4161: Let DeleteShiftDirectionEnum = -4159 ' xlShiftToRight -4161  -- xlShiftToLeft -4159 Zellen werden nach links verschoben.    XlDeleteShiftDirection Enumeration xlShiftToLeft -4159 Cells are shifted to the left
  112.    End Select
  113. '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
  114. Application.Range("" & refNewRngAreaAttempt & "").Delete Shift:=DeleteShiftDirectionEnum  ' This I find good Hierarchical Object Orientated Programming syntaxly correct approach
  115. 'Let Application.Range("" & refNewRngAreaAttempt & "").Value = arrVls() ' We may assign the values of an Array directly to a spreadsheet range
  116. MsgBox prompt:="Finally, the standard code line will be used, based on your given options"
  117. Rem 4  Final "black box" code line using all parameters ...
  118.  Application.Wait (Now + TimeValue("0:00:01")) ' Short pause, then all the above will be repated with the standard Range.Insert code line
  119. Application.Range("" & refNewRngAreaAttempt & "").Insert Shift:=InsertShiftDirectionEnum, CopyOrigin:=FormatCopyOrigin    ' https://powerspreadsheets.com/excel-vba-insert-row/#Insert-Rows-with-the-RangeInsert-Method
  120. 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"
  121.  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"
  122.  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)) & ""
  123. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement