Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ' 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement