Appendix Thread. ( Codes for other Threads, etc.) Event Coding Drpdown Data validation

Printable View

Show 40 post(s) from this thread on one page

12-09-2018, 08:40 PM
DocAElstein

Pubic Properly Leting Get in Class object modules

Code for this post:
http://www.eileenslounge.com/viewtop...=31395#p242918

Code:

' Leave some lines free above ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31395#p242918 Sub WotchaGotInHorizontalClit() 'Examine what is copied to clipboard from a row, and paste it into code module Rem 0 Test range Range("A1:C1").Value = Array("A1", "B1", "C1") Rem 1 Clitbored Range("A1:C1").Copy Dim objDataObject As Object ' DataObject Late Binding equivalent ' http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/ http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/ objDataObject.GetFromClipboard Dim strIn As String: Let strIn = objDataObject.GetText() 'String of range as held in clitbored Rem 2 examine string from clitbored Dim myLenf As Long: Let myLenf = Len(strIn) Dim cnt As Long For cnt = 1 To myLenf Dim Caracter As Variant ' String Let Caracter = Mid(strIn, cnt, 1) Dim WotchaGot As String If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then ' Check for normal characters Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " Else Select Case Caracter Case " " Let WotchaGot = WotchaGot & """" & " " & """" & " & " Case vbCr Let WotchaGot = WotchaGot & "vbCr & " Case vbLf Let WotchaGot = WotchaGot & "vbLf & " Case vbCrLf Let WotchaGot = WotchaGot & "vbCrLf & " Case """" Let WotchaGot = WotchaGot & """" & """" & """" & " & " Case vbTab Let WotchaGot = WotchaGot & "vbTab & " Case Else WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & " 'Let CaseElse = Caracter End Select End If Next cnt If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot Rem 4 paste into code module On Error Resume Next ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule.AddFromString "Rem " & strIn ' a Rem is added to stop the code module showing red error Set objDataObject = Nothing End Sub ' Sub WotchaGotInCodeWindowHorizontal() ' Examine first line of text in the code module Rem 1 Put first line from code module into a string Dim strVonCodMod As String Let strVonCodMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule.Lines(Startline:=1, Count:=1) Let strVonCodMod = Replace(strVonCodMod, "Rem ", "", 1, -1, vbBinaryCompare) Rem 2 examine string from code module line 1 Dim myLenf As Long: Let myLenf = Len(strVonCodMod) Dim cnt As Long For cnt = 1 To myLenf Dim Caracter As Variant ' String Let Caracter = Mid(strVonCodMod, cnt, 1) Dim WotchaGot As String If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " Else Select Case Caracter Case " " Let WotchaGot = WotchaGot & """" & " " & """" & " & " Case vbCr Let WotchaGot = WotchaGot & "vbCr & " Case vbLf Let WotchaGot = WotchaGot & "vbLf & " Case vbCrLf Let WotchaGot = WotchaGot & "vbCrLf & " Case """" Let WotchaGot = WotchaGot & """" & """" & """" & " & " Case vbTab Let WotchaGot = WotchaGot & "vbTab & " Case Else WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & " 'Let CaseElse = Caracter End Select End If Next cnt If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot Rem 3 clipbored '3a Put string from first code module line in clipbored Dim objDataObject As Object ' Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objDataObject.SetText strVonCodMod objDataObject.PutInClipboard Set objDataObject = Nothing '3b paste string from first code module line into worksheet Range("A1:C1").ClearContents Paste Destination:=Range("A1") Rem 4 Delete first line from code module On Error Resume Next ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule.DeleteLines Startline:=1, Count:=1 End Sub ' Sub WotchaGotInVirticalClit() ''Examine what is copied to clipboard from a column, and paste it into code module Rem 0 Test range Dim WhoRay(1 To 3, 1 To 1) As String: Let WhoRay(1, 1) = "A1": Let WhoRay(2, 1) = "A2": Let WhoRay(3, 1) = "A3" Let Range("A1:A3").Value = WhoRay Rem 1 Clipboard Range("A1:A3").Copy Dim objDataObject As Object Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objDataObject.GetFromClipboard Dim strIn As String: Let strIn = objDataObject.GetText() Rem 2 Examine string held in clipboard from a copy from a column Dim myLenf As Long: Let myLenf = Len(strIn) Dim cnt As Long For cnt = 1 To myLenf Dim Caracter As Variant ' String Let Caracter = Mid(strIn, cnt, 1) Dim WotchaGot As String If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " Else Select Case Caracter Case " " Let WotchaGot = WotchaGot & """" & " " & """" & " & " Case vbCr Let WotchaGot = WotchaGot & "vbCr & " Case vbLf Let WotchaGot = WotchaGot & "vbLf & " Case vbCrLf Let WotchaGot = WotchaGot & "vbCrLf & " Case """" Let WotchaGot = WotchaGot & """" & """" & """" & " & " Case vbTab Let WotchaGot = WotchaGot & "vbTab & " Case Else WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & " Let CaseElse = Caracter End Select End If Next cnt If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot Rem 4 Paste stringt from clipboard into top of code module On Error Resume Next ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule.AddFromString "Rem " & Replace(strIn, vbLf, vbLf & "Rem ", 1, 2, vbBinaryCompare) Set objDataObject = Nothing End Sub Sub WotchaGotInCodeWindowVertical() ' Examins what is held in a code module after pasting in a column froma worksheet Rem 1 Put first 4 lines from code module into a string Dim strVonCodMod As String Let strVonCodMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule.Lines(Startline:=1, Count:=4) Let strVonCodMod = Replace(strVonCodMod, "Rem ", "", 1, -1, vbBinaryCompare) Rem 2 Examine contents of string Dim myLenf As Long: Let myLenf = Len(strVonCodMod) Dim cnt As Long For cnt = 1 To myLenf Dim Caracter As Variant ' String Let Caracter = Mid(strVonCodMod, cnt, 1) Dim WotchaGot As String If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " Else Select Case Caracter Case " " Let WotchaGot = WotchaGot & """" & " " & """" & " & " Case vbCr Let WotchaGot = WotchaGot & "vbCr & " Case vbLf Let WotchaGot = WotchaGot & "vbLf & " Case vbCrLf Let WotchaGot = WotchaGot & "vbCrLf & " Case """" Let WotchaGot = WotchaGot & """" & """" & """" & " & " Case vbTab Let WotchaGot = WotchaGot & "vbTab & " Case Else WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & " 'Let CaseElse = Caracter End Select End If Next cnt If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot Rem 3 Clipboard '3a Put string into clipboard Dim objDataObject As Object ' Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objDataObject.SetText strVonCodMod objDataObject.PutInClipboard Set objDataObject = Nothing '3b Paste into worksheet from clipboard Paste Destination:=Range("A1") Rem 4 Delet first 4 rows from code module On Error Resume Next ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule.DeleteLines Startline:=1, Count:=4 End Sub
12-09-2018, 08:42 PM
DocAElstein

1 Attachment(s)

Continuation fron last Post and Extra codes for Yasser:

Continued from above....

Code:

Sub Pubic_Properly_Let_RngAsString_() ' Examination of a range copied to clipboard, then paste to Private Class code module Range("A1:C1").Value = Array("A1", "B1", "C1") Range("A2:C2").Value = Array("A2", "B2", "C2") Range("A3:C3").Value = Array("A3", "B3", "C3") Range("A1:C3").Copy Dim objDataObject As Object Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objDataObject.GetFromClipboard Dim strIn As String: Let strIn = objDataObject.GetText() Dim myLenf As Long: Let myLenf = Len(strIn) Dim cnt As Long For cnt = 1 To myLenf Dim Caracter As Variant ' String Let Caracter = Mid(strIn, cnt, 1) Dim WotchaGot As String If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Then Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " Else Select Case Caracter Case " " Let WotchaGot = WotchaGot & """" & " " & """" & " & " Case vbCr Let WotchaGot = WotchaGot & "vbCr & " Case vbLf Let WotchaGot = WotchaGot & "vbLf & " Case vbCrLf Let WotchaGot = WotchaGot & "vbCrLf & " Case """" Let WotchaGot = WotchaGot & """" & """" & """" & " & " Case vbTab Let WotchaGot = WotchaGot & "vbTab & " Case Else WotchaGot = WotchaGot & """" & "SomeFink" & """" & " & " End Select End If Next cnt If WotchaGot <> "" Then Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot: Debug.Print MsgBox Prompt:=Replace(WotchaGot, "vbLf & ", "vbLf" & vbCrLf, 1, -1, vbBinaryCompare): Debug.Print Replace(WotchaGot, "vbLf & ", "vbLf" & vbCrLf, 1, -1, vbBinaryCompare): Debug.Print MsgBox Prompt:=Replace(WotchaGot, "vbTab", """ | """, 1, -1, vbBinaryCompare): Debug.Print Replace(WotchaGot, "vbTab", """ | """, 1, -1, vbBinaryCompare): Debug.Print Let strIn = Replace(strIn, vbTab, " | ", 1, -1, vbBinaryCompare) ' replace tab with | MsgBox Prompt:=strIn: Debug.Print strIn Let strIn = "Rem " & Replace(strIn, vbLf, vbLf & "Rem ", 1, 2, vbBinaryCompare) ' add some Rems to prevent red error in code window Debug.Print On Error Resume Next ThisWorkbook.VBProject.VBComponents("Tabelle1").CodeModule.AddFromString strIn Set objDataObject = Nothing End Sub Sub Fumic_Properly_Get_Rng_AsString() ' Paste rworksheet range stored in code modulle back to worksheet Range("A1:C3").ClearContents ' Dim strVonCodMod As String Let strVonCodMod = ThisWorkbook.VBProject.VBComponents("Tabelle1").CodeModule.Lines(Startline:=1, Count:=4) Let strVonCodMod = Replace(strVonCodMod, "Rem ", "", 1, -1, vbBinaryCompare) Let strVonCodMod = Replace(strVonCodMod, " | ", vbTab, 1, -1, vbBinaryCompare) Dim objDataObject As Object ' Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objDataObject.SetText strVonCodMod objDataObject.PutInClipboard Set objDataObject = Nothing Paste Destination:=Range("A1") On Error Resume Next ThisWorkbook.VBProject.VBComponents("Tabelle1").CodeModule.DeleteLines Startline:=1, Count:=4 End Sub

_.________________________________________________ ______________
Extra Codes For Yassers Normal Excel File, "NormalExcelFile.xlsm" : http://eileenslounge.com/viewtopic.p...=31395#p242964

Code:

Option Explicit Private Sub Publics_Probably_Let_RngAsString__() ' Input of range to Private Properties storage Rem 0 test data range is selection. Select a range before running this code Dim rngSel As Range: Set rngSel = Selection ' selected range for later reference Rem 1 Copy range to clipbored rngSel.Copy Rem 2 put data currently in clipboard into a string Dim objDataObject As Object ' DataObject ' This will be for an an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. But it is a DataObject. It has the Methods I need to send to and get text to the Clipboard. ' http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/ http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/ objDataObject.GetFromClipboard ' The data object has the long text string from the clipboard at this point 'rngSel.ClearContents ' we can't do this here, not sure why?? Dim strIn As String: Let strIn = objDataObject.GetText() ' The string variable, strIn, is given the long string rngSel.ClearContents ' do this now. (If we did it before, the contents of the clipboard are typically emptied, so that would be poo. I don't know why the clipboard needs to be full still fir the last code line?? Rem 3 manipulate string to substitute vbTab with arbritrary character combination - in next code this will be replaced. We do this because the vbTab is lost when pasting into a code module Let strIn = Replace(strIn, vbTab, " | ", 1, -1, vbBinaryCompare) ' replacing( in the string , replace vbTab , with " | " , start at first position , replace all occurances , look for an excact case sensitive match as this is qiucker if we don't need to be case insensitive as with option vbTextCompare ) Let strIn = "'_-" & Replace(strIn, vbLf, vbLf & "'_-", 1, -1, vbBinaryCompare) ' add some comment bits to prevent red error in code window Rem 4 add range data Let strIn = "'_-Worksheets(""" & rngSel.Parent.Name & """).Range(""" & rngSel.Address & """)" & vbCrLf & strIn ' Add an extra first header line to indicate the worksheet and range used On Error Resume Next ' I am not quite sure why this is needed ThisWorkbook.VBProject.VBComponents("YassersDump").CodeModule.AddFromString strIn ' As far as i know, this adds from the start of the module. Set objDataObject = Nothing ' This probably is not needed. It upsets Kyle when i do it, but he can take it :-) End Sub Private Sub Publics_Probably_Get_Rng__AsString() ' Output of range from Private Properties Storage Rem 2 get string data form code module Private properties storage Dim strVonCodMod As String '2a Range infomation first line Dim Ws As Worksheet, Rng As Range ' These will be used for the range identification infomation which the next code line gets from the first line in the code module used for the Let strVonCodMod = ThisWorkbook.VBProject.VBComponents("YassersDump").CodeModule.Lines(Startline:=1, Count:=1) ' First line has the Let strVonCodMod = Replace(Replace(Replace(strVonCodMod, "'_-Worksheets(""", ""), """).Range(""", " "), """)", "") ' we want to reduce and change like "Worksheets("Sht").Range("A1")" to "Sht A1" so that we can use split to get the Sheet name and the range address strVonCodMod = Replace(strVonCodMod, "'_-Worksheets(""", "") : strVonCodMod = Replace(strVonCodMod, """).Range(""", " ") : strVonCodMod = Replace(strVonCodMod, """)", "") Set Ws = Worksheets(Split(strVonCodMod)(0)): Set Rng = Ws.Range(Split(strVonCodMod)(1)) ' The returned array from spliting by the space , " " , will have first element (indicie(0)) of like "Sht" and the second element (indicie(1)) of like "A1" '2b get range data Let strVonCodMod = ThisWorkbook.VBProject.VBComponents("YassersDump").CodeModule.Lines(Startline:=2, Count:=Rng.Rows.Count + 1) ' We need rows count+1 because there seems to be a last & vbCr & vbLf http://eileenslounge.com/viewtopic.php?f=30&t=31395#p242941 Let strVonCodMod = Replace(strVonCodMod, "'_-", "", 1, -1, vbBinaryCompare) ' remove the '_- Comment bits Let strVonCodMod = Replace(strVonCodMod, " | ", vbTab, 1, -1, vbBinaryCompare) ' Replace the " | " with a carriage return Rem 3 Put the string into the clipboard Dim objDataObject As Object ' Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") objDataObject.SetText strVonCodMod objDataObject.PutInClipboard Set objDataObject = Nothing Rem 4 Output range data values to spreadsheet Ws.Paste Destination:=Rng Rem 5 On Error Resume Next ThisWorkbook.VBProject.VBComponents("YassersDump").CodeModule.DeleteLines Startline:=1, Count:=Rng.Rows.Count + 1 + 1 ' remove the first header row and all data and the extra last row caused by the extra & vbCr & vbLf End Sub

( XL2020alsm.xlsb https://app.box.com/s/26frr0zzc93q6zsraktove3qypqj714p )
12-24-2018, 01:10 PM
DocAElstein

Sub PubProliferous_Let_RngAsString__()

Routine for following excelfox Thread:
http://www.excelfox.com/forum/showth...0863#post10863 ...

Code:

Sub PubProliferous_Let_RngAsString__() ' Make hardcopy of spreadsheet range to VB Editor insensibly http://www.eileenslounge.com/viewtopic.php?f=30&t=31395#p243002 Rem 0 VBA project instantiated VBIDE Dim VBIDEVBAProj As Object ' For convenience a variable is used for this code module Set VBIDEVBAProj = ThisWorkbook.VBProject.VBE.ActiveCodePane.codemodule ' ThisWorkbook.VBProject.VBComponents(Me.CodeName) 'varible referring to this code module Rem 1 Indicate that this module is being used for text. If Not Right(VBIDEVBAProj.Name, 4) = "_txt" Then Let VBIDEVBAProj.Name = VBIDEVBAProj.Name & "_txt" ' If Not Right(Me.CodeName, 4) = "_txt" Then Let VBIDEVBAProj.Name = Me.CodeName & "_txt" Rem 2 Selected range to clipboard Dim rngSel As Range: Set rngSel = Selection: rngSel.Copy Dim objDataObject As Object ' DataObject ' This will be for an an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. But it is a DataObject. It has the Methods I need to send to and get text to the Clipboard. ' http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/ http://www.excelfox.com/forum/showthread.php/2240-VBA-referring-to-external-shared-Libraries-1)-Early-1-5)-Laterly-Early-and-2)-Late-Binding-Techniques Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/ objDataObject.GetFromClipboard ' The data object has the long text string from the clipboard at this point Dim strIn As String: strIn = objDataObject.GetText() 'This gets the test string from the Data Object ' rngSel.ClearContents ' range is cleared after copying table values to clipboard Rem 3 '3a) replace vbTab with "|" as cell divider to use in the VB editor range value display Let strIn = Replace(strIn, vbTab, "|") ' : Call WotchaGot(strIn) '3b) typically the last two "characters" from the text obtained from a spreadsheet range via the clipboard has a last vbCr & vbLf pair. We rely on this in further lines so this is just to be sure If Not Right(strIn, 2) = vbCr & vbLf Then Let strIn = strIn & vbCr & vbLf ' Typically a last vbcr & vblf is there, and we rely on it, so we make sure here ### Rem 4 add start and stop info Let strIn = "'_-" & Format(Date, "DD MM YYYY") & " Worksheets(""" & rngSel.Parent.Name & """).Range(""" & rngSel.Address & """)" & vbCr & vbLf & strIn & "'_- EOF " & Format(Date, "DD MM YYYY") ' Note in last bit I am relying on having a vbcr & vbLf after existing strIn ### Rem 5 Make array from string using the vbCr & vbLf pair as seperator. This willbe an array of data and the extra start and end rows Dim SpltRws() As String: Let SpltRws() = Split(strIn, vbCr & vbLf, -1, vbBinaryCompare) Rem 6 Determination of code module table characteristics '6a) from split rows array, we can get the number of columns and rows Dim RwCnt As Long, ClCnt As Long Let RwCnt = (UBound(SpltRws()) - LBound(SpltRws())) + 1 ' Allow for any base Dim SpltCls() As String: Let SpltCls() = Split(SpltRws(LBound(SpltRws()) + 1), "|", -1, vbBinaryCompare) ' assume second row is representative of all rows for column number Let ClCnt = (UBound(SpltCls()) - LBound(SpltCls())) + 1 '6b) The next line is a way to make a free line... Because we give a line number in the argument .insertlines Line:= of greater than the current last line number, then that actual number given bears no relation to the actual line number of the code line at which it will be added. ( The line number of the code I am talking about here is , as defined by, or rather as held internally by, and accessed in code coding, by a sequential integer starting at 1 at the top of the code window and counting by +1 for every successive line/row ) Because we give a line number in the argument .insertlines Line:= of greater than the current last line number, then lines will always be added at the next free line, that is to say one line above the last used line. The actual number we give is irrelevant, for numbers we give which are greater than that of the current last used line in the code module. VBIDEVBAProj.insertlines Line:=VBIDEVBAProj.countoflines + 9996, String:="" ' An attempt to insert a line anywhere above the last used line will force a new line at the end. So this is how we force a space. (Trying to insert a line anywhere above the last used line won't work. '6c) Find next free row and last row that we will effectively use Dim CdTblStt As Long, CdTblStp As Long ' these variables will actual hold our start and end lines, but when used below they actually force a new line by virtual of attempting to insert a line above the current last line Let CdTblStt = VBIDEVBAProj.countoflines + 1 ' We find that + 1 or more will take us to the next free line. (We can insert below or equal to last used line and then all will be shifted up. If we add to the last line =___.CountOfLines then the last line will shift up. Effectively CdTblStt is the start row as it is one up from the last row. But if we used any number >=1 for the 1 , then the actual start line which we obtain would still be at .countoflines + 1 Let CdTblStp = CdTblStt + RwCnt - 1 ' last row in this code module to be used. In actual fact this nimber is what it will be. Effectively with using this later in our code, we try to insert at one line furthter than the last line. For any attempt at an insert >= .countoflines+1 we actually add a new line at the end. Rem 7 Add lines from array to to code module , using some string formating http://www.excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings --- Dim TabulatorSyncrenator As String: Let TabulatorSyncrenator = "123456789" ' any lengthed string '7a) Header VBIDEVBAProj.insertlines Line:=CdTblStt, String:=SpltRws(LBound(SpltRws())) '7b) Main looping Start for data rows =============================== Dim Rws As Long For Rws = CdTblStt + 1 To CdTblStp - 1 Step 1 ' At each row of data Dim rvec As Long: Let rvec = -CdTblStt + LBound(SpltRws()) ' This gives the adjustment necerssary to take us from a code module line number to an array indicie in the range rows array, SpltRws(). This works as follows: Our used row number actually forces a new line which has that line number. For the relavant array line number, for example , the first line will need to be the first indicie. For zero base, we need to take off excactly CdTblStt For base 1 iwe need to take off 1 less, so rvec would be -(CdTblStt + 1) Let SpltCls() = Split(SpltRws(Rws + rvec), "|", -1, vbBinaryCompare) 'Split each data row into data columns '7c) to allow some formatting, a string is built up from each column/cell value Dim Cls As Long For Cls = LBound(SpltCls()) To UBound(SpltCls()) Dim TabulatorSyncrenator As String: Let TabulatorSyncrenator = "123456789" ' any lengthed string will do LSet TabulatorSyncrenator = Trim(SpltCls(Cls)) ' this cause a number like " 56" to change to "56 " This allows us to have a fixed length format here in the displayed code editor Dim LineAut As String Let LineAut = LineAut & " | " & TabulatorSyncrenator ' : Debug.Print LineAut Next Cls Let LineAut = Replace(LineAut, " | ", "'_-", 1, 1, vbBinaryCompare) 'Replace first " | " with some sort of 'comment thing VBIDEVBAProj.insertlines Line:=Rws, String:=LineAut ' Note: you could use any from and including one more than the last current line. - effectively here we always try to go >=+1, we are not really defining the line, but just making sure that we add on to the end. Effectively the number in the Line:= does become the line where the string is finally. But it is not directly defined by that. Let LineAut = "" ' Ready for next line use Next Rws ' End main data rows Loop ============================== '7d) End row VBIDEVBAProj.insertlines Line:=CdTblStp, String:=SpltRws(UBound(SpltRws())) ' Note: this line would not go further than last line, so it must be done here *** End Sub
12-24-2018, 01:12 PM
DocAElstein

Sub PubProliferous_Get_Rng__AsString()

Routine for following excelfox Thread
http://www.excelfox.com/forum/showth...0864#post10864 .....

Code:

Sub PubProliferous_Get_Rng__AsString() ' This pastes out all held table range values in this code module Rem 0 VBA project instantiated VBIDE Dim VBIDEVBAProj As Object ' For convenience a variable is used for this code module Set VBIDEVBAProj = ThisWorkbook.VBProject.VBE.ActiveCodePane.codemodule ' ThisWorkbook.VBProject.VBComponents(Me.CodeName) 'varible referring to this code module Rem 1 Do it all Do: Dim EndOFSub As Boolean ' looping while not at End Sub ================================= Do: Dim FOB As Boolean ' looping while in range data ------------------------------ Dim ReedLineIn As String If ReedLineIn = "" Then ' because there is no code line in the next line we will go to Let ReedLineIn = if the condition "" is met 'for an empty line we do nothing apart from having already deleted it ( for all but the first time here at the code start) Else ' We are in data or start or stop-----------------| Dim arrOut As String ' A string for output from clipboard for each found range If Mid(ReedLineIn, 15, 12) = "Worksheets(""" Then ' we are at backward looping end(start) of data Let ReedLineIn = Replace(Replace(Mid(ReedLineIn, 27), """).Range(""", " "), """)", "") 'Let ReedLineIn = Mid(ReedLineIn, 27): ReedLineIn = Replace(ReedLineIn, """).Range(""", " ", 1, 1, vbBinaryCompare): ReedLineIn = Replace(ReedLineIn, """)", "", 1, 1, vbBinaryCompare) 'MsgBox ReedLineIn: Debug.Print ReedLineIn ' ' This is particularly useful in developing codes of this nature, as usally step (F8) mode will often fail due to code lines referrencig this code module which trip up the process somehow Dim Ws As Worksheet, Rng As Range 'variables to use for output range details Set Ws = Worksheets(Split(ReedLineIn)(0)): Set Rng = Ws.Range(Split(ReedLineIn)(1)) ' The returned array from spliting by the space , " " , will have first element (indicie(0)) of like "Sheet1" and the second element (indicie(1)) of like "$B$1:$D$13" ' Section to prepare data for, and to do, the paste out of a data value range Output preparing section !! 'MsgBox arrOut: Debug.Print arrOut Let arrOut = Replace(Replace(arrOut, "'_-", ""), " | ", vbTab) ' The "inner" Replace takes out the "'_-" bit at the start of a line, and the "outer" Replace changes the seperator used in the code module " | " for that which appears to be used by Excel to determine a cell "wall" vbTab 'MsgBox arrOut: Debug.Print arrOut Let arrOut = Replace(arrOut, " ", "", 1, -1, vbBinaryCompare) ' this is intended as a partial solution to removing most of the extra spaces that we added, whilst not removing any intentionally there. You may want to adjust this along with the actual character used to fill in the unused spaces in oder to come up with a better solution to suit specific data types 'MsgBox arrOut: Debug.Print arrOut 'WotchaGot (arrOut) ' routine to examine contents of string Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): objDataObject.SetText arrOut: objDataObject.PutInClipboard ' Text is given to Data object which in turn uses its method to put that in the clipboard Ws.Paste Destination:=Rng 'Worksheets Paste method with optional argument to determine where, ( default would be from top left of active range ) Let arrOut = "" ' Clear the string to allow for collection of next range If Right(VBIDEVBAProj.Name, 4) = "_txt" Then Let VBIDEVBAProj.Name = Replace(VBIDEVBAProj.Name, "_txt", "", 1, 1, vbBinaryCompare) Else ' Section to collect the range value data ( If not at the end section of a data range held in the code window like '_- EOF 22 12 2018 ) If Left(ReedLineIn, 8) = "'_- EOF " Then ' ' Let FOB = True ' Let FOB = True is not needed, as clearing the string arrOut effectively starts us again afresh 'for last data we do nothing apart from having already deleted it Else ' from here we are in data collecting/concatanating into string arrOut +++++ Let arrOut = ReedLineIn & vbCr & vbLf & arrOut ' A simple concatenation along with a new line indicator will give a convenient format of the final data range for use in the Output preparing section !! above Note: we build the string "bachwards" with the next line as first and previous lies after it because the code is looping backwards End If ' we were collecting/concatenating range value data +++++ End If End If ' we are did stuff in data or start or stop-----| Let ReedLineIn = VBIDEVBAProj.Lines(StartLine:=VBIDEVBAProj.countoflines, Count:=1) If ReedLineIn = "End Sub" Or ReedLineIn = "End Function" Then Let EndOFSub = True Else ' after reading in any line, we delete it, unless it was the End of a routine VBIDEVBAProj.DeleteLines StartLine:=VBIDEVBAProj.countoflines, Count:=1 End If Loop While Not EndOFSub = True ' And FOB = False '------------------------------------ 'MsgBox Prompt:="In between data ranges": Let FOB = False ' we could do something here to tell us we are in between range, such as count the ranges, and then set FOB back to zero Loop While EndOFSub = False ' ================================================================ End Sub
12-24-2018, 01:16 PM
DocAElstein

Sub PubeProFannyTeas__GLetner(ByVal strDte As String)

Routine for following excelfox Thread
http://www.excelfox.com/forum/showth...0865#post10865

Code:

Sub TestieCall() Call PubeProFannyTeas__GLetner("23 12 2018") End Sub Sub PubeProFannyTeas__GLetner(ByVal strDte As String) Rem 0 VBA project instantiated VBIDE Dim VBIDEVBAProj As Object ' For convenience a variable is used for this code module Set VBIDEVBAProj = ThisWorkbook.VBProject.VBE.ActiveCodePane.codemodule ' ThisWorkbook.VBProject.VBComponents(Me.CodeName) 'varible referring to this code module Rem 1 This code module data range '1a) get full data range as string Dim Cnt As Long, Lr As Long, ReedLineIn As String Let Lr = VBIDEVBAProj.countoflines: Let Cnt = Lr + 1 Do Let Cnt = Cnt - 1 Let ReedLineIn = VBIDEVBAProj.Lines(StartLine:=Cnt, Count:=1) Loop While Not (Left(ReedLineIn, 7) = "End Sub" Or Left(ReedLineIn, 7) = "End Fun") If Cnt = Lr Then MsgBox Prompt:="No range data values in code module " & VBIDEVBAProj.Name: Exit Sub '1b) Complete data region as single string. Dim strIn As String: Let strIn = VBIDEVBAProj.Lines(StartLine:=Cnt + 1, Count:=Lr - Cnt) Let strIn = Mid(strIn, 3) ' take off first vbCr & vbLf 'WotchaGot (strIn) '1c) split into date ranges, get most recent of any dates to match given strDte Dim DtedRngs() As String: Let DtedRngs() = Split(strIn, vbCr & vbLf & vbCr & vbLf) ' Split range by empty line which is double vbCr & vbLf 'WotchaGot (DtedRngs(0)): Debug.Print: WotchaGot (DtedRngs(1)) For Cnt = UBound(DtedRngs()) To LBound(DtedRngs()) Step -1 '1d)Check for date match, if so the main code working begins Dim FndDte As String: Let FndDte = Mid(DtedRngs(Cnt), 4, 10) ' looking at like this typical start of a data range, '_-23 12 2018 Wo.... we see that 10 characters from character 4 will give us the date If FndDte = strDte Then 'MsgBox Prompt:=FndDte Rem 2 manipulation of found date range Dim strRng As String: Let strRng = DtedRngs(Cnt) Let strRng = Mid(strRng, 27) 'takes off up to start of worksheet name... no speacial reason toher than why not? - its not needed anymore '2a) range info Dim RngInfo As String: Let RngInfo = Left(strRng, InStr(1, strRng, """)" & vbCr & vbLf, vbBinaryCompare) - 1) ' This gets us at like Tabelle1").Range("$I$2513:$J$2514 Dim ShtName As String, RngAdrs As String Let ShtName = Split(RngInfo, """).Range(""", 2, vbBinaryCompare)(0) ' split above string , using as seperator ").Range(" , into 2 bits , for exact computer binary type compare Then we have first array element (indicie (0)) as the worksheet name and the second array element (indicie (1)) as the range address Let RngAdrs = Split(RngInfo, """).Range(""", 2, vbBinaryCompare)(1) ': Debug.Print ShtName & " " & RngAdrs Dim Ws As Worksheet, Rng As Range: Set Ws = Worksheets("" & ShtName & ""): Set Rng = Ws.Range(RngAdrs) '2b) get data value range Let strRng = Mid(strRng, InStr(1, strRng, vbCr & vbLf, vbBinaryCompare) + 2) ' take off first line & the first vbCr & vbLf Let strRng = Left(strRng, InStr(1, strRng, "'_- EOF ", vbBinaryCompare) - 1) ' take off last line, ( but leave on the vbCr & vbLf as that seems to typically be on a string from an excel range 'WotchaGot strRng Let strRng = Replace(strRng, " | ", vbTab, 1, -1, vbBinaryCompare) 'Change code window cell wall seperator for that used by Excel Let strRng = Replace(strRng, "'_-", "", 1, -1, vbBinaryCompare) Let strRng = Replace(strRng, " ", "", 1, -1, vbBinaryCompare) ' Bit of bodge to remove my added spaces 'Debug.Print strRng Rem 3 output to worksheet Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): objDataObject.SetText strRng: objDataObject.PutInClipboard ' Text is given to Data object which in turn uses its method to put that in the clipboard Ws.Paste Destination:=Rng 'Worksheets Paste method with optional argument to determine where, ( default would be from top left of active range ) Exit Sub 'This code only gets the first found range looking from code window bottom Else ' No matching date found yet, so do nothing but End If ' go on to Next Cnt ' next date range ' ( There is no check for no matching date. The code will simple end after all ranges have been looped through.) End Sub

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.youtube.com/watch?v=zHJPliWS9FQ&lc=Ugz39PGfytiMUCmTPTl4AaABAg. 91d_Pbzklsp9zfGbIr8hgW
https://www.youtube.com/watch?v=zHJPliWS9FQ&lc=UgwbcybM8fXnaIK-Y3B4AaABAg.97WIeYeaIeh9zfsJvc21iq
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgzTC8V4jCzDHbmfCHF4AaABAg. 9zaUSUoUUYs9zciSZa959d
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgzTC8V4jCzDHbmfCHF4AaABAg. 9zaUSUoUUYs9zckCo1tvPO
https://www.youtube.com/watch?v=vSjTzhoJFdk&lc=UgwMsgdKKlhr2YPpxXl4AaABAg
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwTUdEgR4bdt6crKXF4AaABAg. 9xmkXGSciKJ9xonTti2sIx
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwWw16qBFX39JCRRm54AaABAg. 9xnskBhPnmb9xoq3mGxu_b
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9xon1p2ImxO
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgybZfNJd3l4FokX3cV4AaABAg. 9xm_ufqOILb9xooIlv5PLY
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9y38bzbSqaG
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgyWm8nL7syjhiHtpBF4AaABAg. 9xmt8i0IsEr9y3FT9Y9FeM
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9xpn-GDkL3o
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg. 9zYoeePv8sZ9zYqog9KZ5B
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9zYlZPKdOpm
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

1 Attachment(s)

Code for Yassser here:
http://www.eileenslounge.com/viewtop...=31529#p243999

Code:

Option Explicit 'I have numbers from 1 to 2319 made in groups in different numbers (in ten groups) as shown in column F 'How can I get random distribution for those group to have the same range of numbers from 1 to 2319 'but in different order and at the same time to have the same number inside each group 'Example 'Group 6 from 1267 - 1489 >> the number inside that group is 223 'Suppose the random choice make this group the first one so the expected result would be 1 - 223 ' 'then suppose the second selected group is group 8 which is 1699 - 1938 >> the number inside that group is 240 'So that new group in the expected result would start at 224 '(which is the last number in the previous result and the finish number would be 463 ' '... 'Is it possible to do that in random order? ' Sub RandomDistribution4Numbers() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31529 Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1") Dim arrSN() As Variant: Let arrSN() = Ws1.Range("F2:F" & Ws1.Range("F" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs Dim LstGrpStp As Long: Let LstGrpStp = 0 ' last number used at end of random number group Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To UBound(arrSN(), 1), 1 To 1) ' Array for output values Do ' we loop while we have not yet filled all of the output array, arrGrpsOut() Dim Rnd1ToUBnd As Long ' For a random array indicie from 1 to the UBound "row" of the input, (and output), arraysd Randomize: Let Rnd1ToUBnd = Int(UBound(arrSN(), 1) * Rnd) + 1 If arrGrpsOut(Rnd1ToUBnd, 1) = "" Then ' Not yet filled this element in output array, so do the main stuff Dim OutElsFilled As Long: Let OutElsFilled = OutElsFilled + 1 ' count of number of outup array elements filled ' split F column (arrSN()) numbers to get range of numbers Dim SpltRng() As String: Let SpltRng() = Split(arrSN(Rnd1ToUBnd, 1), " - ", 2, vbBinaryCompare) Dim Rng As Long: Let Rng = SpltRng(1) - SpltRng(0) ' Range of numbers Dim Stt As Long, Stp As Long: Let Stt = LstGrpStp + 1: Let Stp = LstGrpStp + Rng + 1 ' Start and stop of range of numbers ' build output array with the numbers Let arrGrpsOut(Rnd1ToUBnd, 1) = Stt & " - " & Stp Let LstGrpStp = Stp ' Last highest used number Else ' If we come here then our random number must of been for an indicie of an array element already filled - so this probably makes the code a bit inefficient End If Loop While OutElsFilled < UBound(arrSN(), 1) ' we loop while we have not yet filled all of the output array, arrGrpsOut(), which is determined by if we did the main stuff as many times as there are elements in the input/Output arrays Let Ws1.Range("G2").Resize(UBound(arrSN(), 1)).Value = arrGrpsOut End Sub ' Sub RandomizeGroups() ' Hans code ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31529#p244006 Dim arr As Variant Dim lb As Long Dim ub As Long Dim i As Long Dim j As Long Dim tmp As Long Dim n As Long Dim idx() As Long Dim itm() As String Dim grp() As String arr = Range("F2:F11").Value lb = LBound(arr, 1) ub = UBound(arr, 1) ReDim idx(lb To ub) ReDim grp(lb To ub) For i = lb To ub idx(i) = i Next i For i = lb To ub j = Application.RandBetween(lb, ub) tmp = idx(i) idx(i) = idx(j) idx(j) = tmp Next i n = 1 For i = lb To ub itm = Split(arr(idx(i), 1), " - ") grp(idx(i)) = n & " - " & n + itm(1) - itm(0) n = n + itm(1) - itm(0) + 1 Next i Range("G2:G11").Value = Application.Transpose(grp) End Sub

Typical results from my code are shown in column G. ( The code works on the data from column F )

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
E

F

G

H

I

1
for illustration
SN
Some expected result Number inside Group

2

1

1 - 244

923 - 1166

244

3

2

245 - 448

1 - 204

204

4

3

449 - 750

398 - 699

302

5

4

751 - 1003

1879 - 2131

253

6

5

1004 - 1266

1167 - 1429

263

7

6

1267 - 1489

700 - 922

1 - 223

223

8

7

1490 - 1698

1430 - 1638

209

9

8

1699 - 1938

1639 - 1878

224 - 463

240

10

9

1939 - 2126

2132 - 2319

188

11

10

2127 - 2319

205 - 397

193

Worksheet: Sheet1

here below a few more runs, showing just column G
_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
G

1

2

591 - 834

3

835 - 1038

4

1502 - 1803

5

2067 - 2319

6

1804 - 2066

7

1279 - 1501

8

382 - 590

9

1039 - 1278

10

194 - 381

11

1 - 193

Worksheet: Sheet1

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

254 - 497

2076 - 2319

1470 - 1713

638 - 881

498 - 701

517 - 720

1923 - 2126

1 - 204

1174 - 1475

1774 - 2075

705 - 1006

2018 - 2319

1 - 253

264 - 516

264 - 516

1354 - 1606

911 - 1173

1 - 263

1 - 263

882 - 1144

1476 - 1698

1551 - 1773

1247 - 1469

1607 - 1829

702 - 910

1342 - 1550

1714 - 1922

1145 - 1353

1892 - 2131

721 - 960

1007 - 1246

205 - 444

2132 - 2319

1154 - 1341

517 - 704

1830 - 2017

1699 - 1891

961 - 1153

2127 - 2319

445 - 637

Worksheet: Sheet1

_Row\^Col	E	F	G	H	I
1	for illustration	SN		Some expected result	Number inside Group
2	1	1 - 244	923 - 1166		244
3	2	245 - 448	1 - 204		204
4	3	449 - 750	398 - 699		302
5	4	751 - 1003	1879 - 2131		253
6	5	1004 - 1266	1167 - 1429		263
7	6	1267 - 1489	700 - 922	1 - 223	223
8	7	1490 - 1698	1430 - 1638		209
9	8	1699 - 1938	1639 - 1878	224 - 463	240
10	9	1939 - 2126	2132 - 2319		188
11	10	2127 - 2319	205 - 397		193

_Row\^Col	G
1
2	591 - 834
3	835 - 1038
4	1502 - 1803
5	2067 - 2319
6	1804 - 2066
7	1279 - 1501
8	382 - 590
9	1039 - 1278
10	194 - 381
11	1 - 193

2 Attachment(s)

Code:

' Sub Populatenumbersfromrangeofnumbers2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31531&p=244015#p244015 Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1") Dim arrSN() As Variant: Let arrSN() = Ws1.Range("F2:F" & Ws1.Range("F" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To 1) ' 1 Dimensional Array for output values. Dim cnt As Long, Cnt2 As Long, Rng2 As Long, Rng1 As Long, Rws As Long For cnt = LBound(arrSN(), 1) To UBound(arrSN(), 1) Dim SpltRng() As String: Let SpltRng() = Split(arrSN(cnt, 1), " - ", 2, vbBinaryCompare) Dim arrRws() As Variant 'Array for 1 2 3 4 5 6 7 etc Let arrRws() = Evaluate("=row(" & SpltRng(0) & ":" & SpltRng(1) & ")") ' This returns a one "column" 2 Dimensional array of all the numbers between the ranges Let Rng1 = UBound(arrGrpsOut()) + 1 ' The start of a range must be just above the last one Let Rng2 = Rng1 + SpltRng(1) - SpltRng(0) ' 'this gives the top of the current range in indicies of arrGrpsOut() ReDim Preserve arrGrpsOut(1 To Rng2) For Cnt2 = Rng1 To Rng2 Let arrGrpsOut(Cnt2) = arrRws(Cnt2 - Rng1 + 1, 1) ' Cnt2 is the indicie in arrGrpsOut(), for the indicie in arrRws() we need to start at 1, then 2 3 4 5 Next Cnt2 Next cnt Dim arrOut() As String: ReDim arrOut(1 To UBound(arrGrpsOut()) - 1, 1 To 1) ' a 2 dimension, 1 column , to be easy to post the results of this array into a column For cnt = 1 To UBound(arrGrpsOut()) - 1 Let arrOut(cnt, 1) = arrGrpsOut(cnt + 1) Next cnt Let Ws1.Range("K2").Resize(UBound(arrOut(), 1), 1) = arrOut() End Sub Sub Populatenumbersfromrangeofnumbers2_2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=31531&p=244015#p244015 Dim Ws1 As Worksheet: Set Ws1 = Worksheets("Sheet1") Dim arrSN() As Variant: Let arrSN() = Ws1.Range("G2:G" & Ws1.Range("G" & Rows.Count & "").End(xlUp).Row & "").Value ' range of current SNs Dim arrGrpsOut() As String: ReDim arrGrpsOut(1 To 1) ' 1 Dimensional Array for output values. Dim cnt As Long, Cnt2 As Long, Rng2 As Long, Rng1 As Long, Rws As Long For cnt = LBound(arrSN(), 1) To UBound(arrSN(), 1) Dim SpltRng() As String: Let SpltRng() = Split(arrSN(cnt, 1), " - ", 2, vbBinaryCompare) Dim arrRws() As Variant 'Array for 1 2 3 4 5 6 7 etc Let arrRws() = Evaluate("=row(" & SpltRng(0) & ":" & SpltRng(1) & ")") ' This returns a one "column" 2 Dimensional array of all the numbers between the ranges Let Rng1 = UBound(arrGrpsOut()) + 1 ' The start of a range must be just above the last one Let Rng2 = Rng1 + SpltRng(1) - SpltRng(0) ' 'this gives the top of the current range in indicies of arrGrpsOut() ReDim Preserve arrGrpsOut(1 To Rng2) For Cnt2 = Rng1 To Rng2 Let arrGrpsOut(Cnt2) = arrRws(Cnt2 - Rng1 + 1, 1) ' Cnt2 is the indicie in arrGrpsOut(), for the indicie in arrRws() we need to start at 1, then 2 3 4 5 Next Cnt2 Next cnt Dim arrOut() As String: ReDim arrOut(1 To UBound(arrGrpsOut()) - 1, 1 To 1) ' a 2 dimension, 1 column , to be easy to post the results of this array into a column For cnt = 1 To UBound(arrGrpsOut()) - 1 Let arrOut(cnt, 1) = arrGrpsOut(cnt + 1) Next cnt Let Ws1.Range("L2").Resize(UBound(arrOut(), 1), 1) = arrOut() End Sub

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

SN
Some expected result Number inside Group

1 - 244

1600 - 1843

244
1 1600

245 - 448

700 - 903

204
2 1601

449 - 750

398 - 699

302
3 1602

751 - 1003

1844 - 2096

253
4 1603

1004 - 1266

1144 - 1406

263
5 1604

1267 - 1489

2097 - 2319

1 - 223

223
6 1605

1490 - 1698

189 - 397

209
7 1606

1699 - 1938

904 - 1143

224 - 463

240
8 1607

1939 - 2126

1 - 188

188
9 1608

2127 - 2319

1407 - 1599

193
10 1609

2319
11 1610

12 1611

13 1612

14 1613

15 1614

16 1615

17 1616

18 1617

19 1618

20 1619

21 1620

22 1621

23 1622

24 1623

25 1624

26 1625

27 1626

28 1627

29 1628

30 1629

31 1630

32 1631

33 1632

34 1633

Worksheet: Sheet1

FinalKandLColumns.JPG : https://imgur.com/NF6f2vL
Attachment 2124

01-01-2019, 07:41 PM
DocAElstein

1 Attachment(s)

Code for suppot of this Thread:
http://eileenslounge.com/viewtopic.php?f=30&t=31540

Code:

Sub SpltTests() Call Splt(1, 244, 1377, 1620) End Sub Function Splt(ByVal N1a As Long, ByVal N1b As Long, ByVal N2a As Long, ByVal N2b As Long) As Variant ' Variant as I don't know yet what might be wanted as output Rem 1 full columns of data - full data arrays Dim Clm1() As Variant: Let Clm1() = Evaluate("=row(" & N1a & ":" & N1b & ")") ' This returns a one "column" 2 Dimensional array of all the numbers between N a and N b Dim Clm2() As Variant: Let Clm2() = Evaluate("=row(" & N2a & ":" & N2b & ")") Rem 2 get total number of arrays needed Dim En As Long ' We want Let En = Int(((N1b - N1a) + 1) / 40) + 1 Rem 3a Not so simple maths to get some grouped numbers for top left of output arrays ' I need rows 1,1,1,42,42,42,83, columns 1,4,7,1,4,7,1 Dim ltrEn As String: Let ltrEn = Cltr(En) ' column letter from column number - G in example data Dim ltrEnPlus3 As String: Let ltrEnPlus3 = Cltr(En + 3) Dim Rws() As Variant ' row co ordinates of outout arrays Let Rws() = Evaluate("=Index((int((column(D:" & ltrEnPlus3 & ")-1)/3)),)") ' Evaluate("=Index((int((column(D:J)-1)/3)),)") 'returns {1, 1, 1, 2, 2, 2, 3} Dim Clms() As Variant ' column co ordinates of output arrays Let Clms() = Evaluate("=Index((mod(column(A:" & ltrEn & ")-1,3)+1),)") ' Evaluate("=Index((mod(column(A:G)-1,3)+1),)") 'Returns { 1, 2, 3, 1, 2, 3, 1 } Dim Cnt ' Loop for all data sections ================================================== For Cnt = 1 To En Rem 3b Top left for each array Dim rTL As Long, cTL As Long Let rTL = ((Rws(Cnt) - 1) * 41) + 1 ' In the looping this will give 1,1,1,42,42,42,83 Let cTL = ((Clms(Cnt) - 1) * 3) + 1 ' In the looping this will give 1,4,7,1,4,7,1 Rem 4 Columns of data for each loop Dim ClmOut1() As Variant, ClmOut2() As Variant '4a) use Index with arrays to get part of the sections from full data arrays Let ClmOut1() = Application.Index(Clm1(), Evaluate("=column(" & Cltr(((Cnt - 1) * 40) + 1) & ":" & Cltr(Cnt * 40) & ")"), 0) ' column 1 Let ClmOut2() = Application.Index(Clm2(), Evaluate("=column(" & Cltr(((Cnt - 1) * 40) + 1) & ":" & Cltr(Cnt * 40) & ")"), 0) ' column 2 Dim ClmOut1_1(1 To 40, 1 To 1) As Variant, ClmOut2_1(1 To 40, 1 To 1) As Variant ' I need Variant so as to get empty back for last array in loop paste out Dim Cnt2 As Long '4b) Loop to get convenient for output 2 dimensional 1 column arrays For Cnt2 = 1 To 40 If IsError(ClmOut1(Cnt2)) Then Exit For ' To stop filling last array for large than top range value Let ClmOut1_1(Cnt2, 1) = ClmOut1(Cnt2) ' column 1 Let ClmOut2_1(Cnt2, 1) = ClmOut2(Cnt2) ' column 2 Next Cnt2 Rem 5 Output of arrays to worksheet '5a Title Dim Tital(1 To 1, 1 To 2) As String: Let Tital(1, 1) = "S1": Let Tital(1, 2) = "S2" '5b Columns of data Dim WsRes As Worksheet: Set WsRes = Worksheets("Result") WsRes.Cells.Item(rTL, cTL).Resize(1, 2).Value = Tital() ' Title WsRes.Cells.Item(rTL + 1, cTL).Resize(40, 1).Value = ClmOut1_1() ' column 1 WsRes.Cells.Item(rTL + 1, cTL + 1).Resize(40, 1).Value = ClmOut2_1() 'column 2 Erase ClmOut1_1(), ClmOut2_1() ' without doing this out last array will not have any empties in it Next Cnt ' ============================================================================= End Function ' Column letter http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980 Function Cltr(ByVal lclm As Long) As String 'Using chr function and Do while loop For example http://www.excelforum.com/excel-programming-vba-macros/796472-how-to-go-from-column-number-to-column-letter.html Do Let Cltr = Chr(65 + (((lclm - 1) Mod 26))) & Cltr Let lclm = (lclm - (1)) \ 26 'This gives the number of 26's ( if any ), but just the excact part, in the next number down , - so applying the rest formula to this new number will again leave a difference "left over" rest. Loop While lclm > 0 'Only loop further if number was big enough to still have 0-25's in it End Function 'Dim arr1_40() As Variant: Let arr1_40() = Evaluate("=column(A:AN)") ' {1, 2, 3 ....40}

_.__________________________

It will take numbers like 1, 244, 1377, 1620 and then give your wanted result (I think, like Hans said, your test data is a bit wrong – check your row 82 should be 83 I think )
The function is hard coded inside for 40 data rows, and 3 columns of Result data, but you could easily adapt that for different numbers
Rem 1 gives the entire 2 columns of results , similar to in some of your last Threads. Full data arrays are got here for the ranges, ( in your example 1 - 244 and 1377 – 1620 )

Rem 2 does some simple maths to get the number of final sections, ( 7 in your example )

Rem 3 does some not so simple maths to get
row and column, Top left indices,
rTL and cTL , of where the output should go. You want
1,1,1,42,42,42,83 and 1,4,7,1,4,7,1

Rem 4 Uses Index( arrIn() , {1,2,3,4 } , 0 ) type stuff that you know about for pulling out part of an array to get the data section columns of data

Rem 5 Pastes out to the worksheet

Alan

Typical Output as seen in the next 2 posts,

First 3 section output after running Sub SpltTests() from last post ( http://www.excelfox.com/forum/showth...0881#post10881 , https://tinyurl.com/yd95w5v2 )

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

H

1

S1

S2

S1

S2

S1

S2

2

1

1377

41

1417

81

1457

3

2

1378

42

1418

82

1458

4

3

1379

43

1419

83

1459

5

4

1380

44

1420

84

1460

6

5

1381

45

1421

85

1461

7

6

1382

46

1422

86

1462

8

7

1383

47

1423

87

1463

9

8

1384

48

1424

88

1464

10

9

1385

49

1425

89

1465

11

10

1386

50

1426

90

1466

12

11

1387

51

1427

91

1467

13

12

1388

52

1428

92

1468

14

13

1389

53

1429

93

1469

15

14

1390

54

1430

94

1470

16

15

1391

55

1431

95

1471

17

16

1392

56

1432

96

1472

18

17

1393

57

1433

97

1473

19

18

1394

58

1434

98

1474

20

19

1395

59

1435

99

1475

21

20

1396

60

1436

100

1476

22

21

1397

61

1437

101

1477

23

22

1398

62

1438

102

1478

24

23

1399

63

1439

103

1479

25

24

1400

64

1440

104

1480

26

25

1401

65

1441

105

1481

27

26

1402

66

1442

106

1482

28

27

1403

67

1443

107

1483

29

28

1404

68

1444

108

1484

30

29

1405

69

1445

109

1485

31

30

1406

70

1446

110

1486

32

31

1407

71

1447

111

1487

33

32

1408

72

1448

112

1488

34

33

1409

73

1449

113

1489

35

34

1410

74

1450

114

1490

36

35

1411

75

1451

115

1491

37

36

1412

76

1452

116

1492

38

37

1413

77

1453

117

1493

39

38

1414

78

1454

118

1494

40

39

1415

79

1455

119

1495

41

40

1416

80

1456

120

1496

42

S1

S2

S1

S2

S1

S2

43

121

1497

161

1537

201

1577

Worksheet: Result

_Row\^Col	A	B	D	E	G	H
1	S1	S2	S1	S2	S1	S2
2	1	1377	41	1417	81	1457
3	2	1378	42	1418	82	1458
4	3	1379	43	1419	83	1459
5	4	1380	44	1420	84	1460
6	5	1381	45	1421	85	1461
7	6	1382	46	1422	86	1462
8	7	1383	47	1423	87	1463
9	8	1384	48	1424	88	1464
10	9	1385	49	1425	89	1465
11	10	1386	50	1426	90	1466
12	11	1387	51	1427	91	1467
13	12	1388	52	1428	92	1468
14	13	1389	53	1429	93	1469
15	14	1390	54	1430	94	1470
16	15	1391	55	1431	95	1471
17	16	1392	56	1432	96	1472
18	17	1393	57	1433	97	1473
19	18	1394	58	1434	98	1474
20	19	1395	59	1435	99	1475
21	20	1396	60	1436	100	1476
22	21	1397	61	1437	101	1477
23	22	1398	62	1438	102	1478
24	23	1399	63	1439	103	1479
25	24	1400	64	1440	104	1480
26	25	1401	65	1441	105	1481
27	26	1402	66	1442	106	1482
28	27	1403	67	1443	107	1483
29	28	1404	68	1444	108	1484
30	29	1405	69	1445	109	1485
31	30	1406	70	1446	110	1486
32	31	1407	71	1447	111	1487
33	32	1408	72	1448	112	1488
34	33	1409	73	1449	113	1489
35	34	1410	74	1450	114	1490
36	35	1411	75	1451	115	1491
37	36	1412	76	1452	116	1492
38	37	1413	77	1453	117	1493
39	38	1414	78	1454	118	1494
40	39	1415	79	1455	119	1495
41	40	1416	80	1456	120	1496
42	S1	S2	S1	S2	S1	S2
43	121	1497	161	1537	201	1577

4, 5, 6 and 7 data section output after running Sub SpltTests() from http://www.excelfox.com/forum/showth...0881#post10881
https://tinyurl.com/yd95w5v2

_____ Workbook: Sample.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
A

B

C

D

E

F

G

H

41

40

1416

80

1456

120

1496

42

S1

S2

S1

S2

S1

S2

43

121

1497

161

1537

201

1577

44

122

1498

162

1538

202

1578

45

123

1499

163

1539

203

1579

46

124

1500

164

1540

204

1580

47

125

1501

165

1541

205

1581

48

126

1502

166

1542

206

1582

49

127

1503

167

1543

207

1583

50

128

1504

168

1544

208

1584

51

129

1505

169

1545

209

1585

52

130

1506

170

1546

210

1586

53

131

1507

171

1547

211

1587

54

132

1508

172

1548

212

1588

55

133

1509

173

1549

213

1589

56

134

1510

174

1550

214

1590

57

135

1511

175

1551

215

1591

58

136

1512

176

1552

216

1592

59

137

1513

177

1553

217

1593

60

138

1514

178

1554

218

1594

61

139

1515

179

1555

219

1595

62

140

1516

180

1556

220

1596

63

141

1517

181

1557

221

1597

64

142

1518

182

1558

222

1598

65

143

1519

183

1559

223

1599

66

144

1520

184

1560

224

1600

67

145

1521

185

1561

225

1601

68

146

1522

186

1562

226

1602

69

147

1523

187

1563

227

1603

70

148

1524

188

1564

228

1604

71

149

1525

189

1565

229

1605

72

150

1526

190

1566

230

1606

73

151

1527

191

1567

231

1607

74

152

1528

192

1568

232

1608

75

153

1529

193

1569

233

1609

76

154

1530

194

1570

234

1610

77

155

1531

195

1571

235

1611

78

156

1532

196

1572

236

1612

79

157

1533

197

1573

237

1613

80

158

1534

198

1574

238

1614

81

159

1535

199

1575

239

1615

82

160

1536

200

1576

240

1616

83

S1

S2

84

241

1617

85

242

1618

86

243

1619

87

244

1620

88

Worksheet: Result

_Row\^Col	A	B	D	E	G	H
41	40	1416	80	1456	120	1496
42	S1	S2	S1	S2	S1	S2
43	121	1497	161	1537	201	1577
44	122	1498	162	1538	202	1578
45	123	1499	163	1539	203	1579
46	124	1500	164	1540	204	1580
47	125	1501	165	1541	205	1581
48	126	1502	166	1542	206	1582
49	127	1503	167	1543	207	1583
50	128	1504	168	1544	208	1584
51	129	1505	169	1545	209	1585
52	130	1506	170	1546	210	1586
53	131	1507	171	1547	211	1587
54	132	1508	172	1548	212	1588
55	133	1509	173	1549	213	1589
56	134	1510	174	1550	214	1590
57	135	1511	175	1551	215	1591
58	136	1512	176	1552	216	1592
59	137	1513	177	1553	217	1593
60	138	1514	178	1554	218	1594
61	139	1515	179	1555	219	1595
62	140	1516	180	1556	220	1596
63	141	1517	181	1557	221	1597
64	142	1518	182	1558	222	1598
65	143	1519	183	1559	223	1599
66	144	1520	184	1560	224	1600
67	145	1521	185	1561	225	1601
68	146	1522	186	1562	226	1602
69	147	1523	187	1563	227	1603
70	148	1524	188	1564	228	1604
71	149	1525	189	1565	229	1605
72	150	1526	190	1566	230	1606
73	151	1527	191	1567	231	1607
74	152	1528	192	1568	232	1608
75	153	1529	193	1569	233	1609
76	154	1530	194	1570	234	1610
77	155	1531	195	1571	235	1611
78	156	1532	196	1572	236	1612
79	157	1533	197	1573	237	1613
80	158	1534	198	1574	238	1614
81	159	1535	199	1575	239	1615
82	160	1536	200	1576	240	1616
83	S1	S2
84	241	1617
85	242	1618
86	243	1619
87	244	1620
88

Show 40 post(s) from this thread on one page

254 - 497	2076 - 2319	1470 - 1713	638 - 881
498 - 701	517 - 720	1923 - 2126	1 - 204
1174 - 1475	1774 - 2075	705 - 1006	2018 - 2319
1 - 253	264 - 516	264 - 516	1354 - 1606
911 - 1173	1 - 263	1 - 263	882 - 1144
1476 - 1698	1551 - 1773	1247 - 1469	1607 - 1829
702 - 910	1342 - 1550	1714 - 1922	1145 - 1353
1892 - 2131	721 - 960	1007 - 1246	205 - 444
2132 - 2319	1154 - 1341	517 - 704	1830 - 2017
1699 - 1891	961 - 1153	2127 - 2319	445 - 637