Appendix Thread. 3 *

**DocAElstein** · 04-12-2021, 05:07 PM

Some extra macros for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=36401
post
https://eileenslounge.com/viewtopic....282498#p282498

Code:

Option Explicit
Sub VergeltungswaffeV1V2() ' http://www.eileenslounge.com/viewtopic.php?f=27&t=36401
Dim Ar As Long, Em As Long
 Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 '   The main data from column 1
Dim V1() As Variant, V2() As Variant: ReDim V1(1 To Em): ReDim V2(1 To Em) ' These will need to be variant because each element is itself an array  ( a 1 D array )
    For Ar = 1 To Em ' The main data rows range
     Let V1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare)              '  I am splitting each data into 2 bits, the first is the data  ID  the second is all the rest
     Let V2(Ar) = Split(StrReverse(V1(Ar)(1)), " ", 6, vbBinaryCompare) '  We are splitting the reversed string, because my second data  CITY  might have a few words, I split the backward string in just enough bits so that the last element is the data  CITY  regardles of how many words are in it
     Let V2(Ar)(0) = StrReverse(V2(Ar)(0)): V2(Ar)(1) = StrReverse(V2(Ar)(1)): V2(Ar)(2) = StrReverse(V2(Ar)(2)): V2(Ar)(3) = StrReverse(V2(Ar)(3)): V2(Ar)(4) = StrReverse(V2(Ar)(4)): V2(Ar)(5) = StrReverse(V2(Ar)(5)) '  The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
    Next Ar
' The end result of the above is that we have two 1 D arrays, V1() and V2(). Each element is itself a 1 D array. We find that strangely that  INDEX  seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the  Index(arr(), Rws(), Clms())  way to get out our final range in any order we like.
 Let Range("B2:B" & Em + 1 & "").Value = Application.Index(V1(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
 Let Range("C2:H" & Em + 1 & "").Value = Application.Index(V2(), Evaluate("=Row(1:" & Em & ")"), Array(6, 5, 4, 3, 2, 1)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
 Range("A1:H1").EntireColumn.AutoFit
End Sub


Sub VergeltungswaffeV1V2_()
Dim Ar As Long, Em As Long
 Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 '   The main data from column 1
Dim V1() As Variant, V2() As Variant: ReDim V1(1 To Em): ReDim V2(1 To Em) ' These will need to be variant because each element is itself an array  ( a 1 D array )
    For Ar = 1 To Em ' The main data rows range
     Let V1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare)              '  I am splitting each data into 2 bits, the first is the data  ID  the second is all the rest
     Let V2(Ar) = Split(StrReverse(V1(Ar)(1)), " ", 6, vbBinaryCompare) '  We are splitting the reversed string, because my second data  CITY  might have a few words, I split the backward string in just enough bits so that the last element is the data  CITY  regardles of how many words are in it
     Let V2(Ar) = Array(StrReverse(V2(Ar)(0)), StrReverse(V2(Ar)(1)), StrReverse(V2(Ar)(2)), StrReverse(V2(Ar)(3)), StrReverse(V2(Ar)(4)), StrReverse(V2(Ar)(5)))      '  The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
    Next Ar
' The end result of the above is that we have two 1 D arrays, V1() and V2(). Each element is itself a 1 D array. We find that strangely that  INDEX  seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the  Index(arr(), Rws(), Clms())  way to get out our final range in any order we like.
 Let Range("B2:B" & Em + 1 & "").Value = Application.Index(V1(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
 Let Range("C2:H" & Em + 1 & "").Value = Application.Index(V2(), Evaluate("=Row(1:" & Em & ")"), Array(6, 5, 4, 3, 2, 1)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
 Range("A1:H1").EntireColumn.AutoFit
End Sub

Sub VergeltungswaffeV1V2__()
Dim Ar As Long, Em As Long
 Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 '   The main data from column 1
Dim V1() As Variant, V2() As Variant: ReDim V1(1 To Em): ReDim V2(1 To Em) ' These will need to be variant because each element is itself an array  ( a 1 D array )
    For Ar = 1 To Em ' The main data rows range
     Let V1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare)              '  I am splitting each data into 2 bits, the first is the data  ID  the second is all the rest
     Let V2(Ar) = Split(StrReverse(V1(Ar)(1)), " ", 6, vbBinaryCompare) '  We are splitting the reversed string, because my second data  CITY  might have a few words, I split the backward string in just enough bits so that the last element is the data  CITY  regardles of how many words are in it
     Let V2(Ar) = Array(StrReverse(V2(Ar)(5)), StrReverse(V2(Ar)(4)), StrReverse(V2(Ar)(3)), StrReverse(V2(Ar)(2)), StrReverse(V2(Ar)(1)), StrReverse(V2(Ar)(0)))      '  The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
    Next Ar
' The end result of the above is that we have two 1 D arrays, V1() and V2(). Each element is itself a 1 D array. We find that strangely that  INDEX  seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the  Index(arr(), Rws(), Clms())  way to get out our final range in any order we like.
 Let Range("B2:B" & Em + 1 & "").Value = Application.Index(V1(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
 Let Range("C2:H" & Em + 1 & "").Value = Application.Index(V2(), Evaluate("=Row(1:" & Em & ")"), Array(1, 2, 3, 4, 5, 6)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
 Range("A1:H1").EntireColumn.AutoFit
End Sub

**DocAElstein** · 04-12-2021, 05:10 PM

Some extra macros for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=36401
post
https://eileenslounge.com/viewtopic....282498#p282498

Code:

Option Explicit
Sub Dik1Dik2_() '
Dim Ar As Long, Em As Long
 Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 '   The main data from column 1
Dim Dik1 As Object, Dik2 As Object: Set Dik1 = CreateObject("Scripting.Dictionary"): Set Dik2 = CreateObject("Scripting.Dictionary")
    For Ar = 1 To Em ' The main data rows range
     Let Dik1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare)              '  I am splitting each data into 2 bits, the first is the data  ID  the second is all the rest
     Let Dik2(Ar) = Split(StrReverse(Dik1(Ar)(1)), " ", 6, vbBinaryCompare) '  We are splitting the reversed string, because my second data  CITY  might have a few words, I split the backward string in just enough bits so that the last element is the data  CITY  regardles of how many words are in it
     Let Dik2(Ar) = Array(StrReverse(Dik2(Ar)(0)), StrReverse(Dik2(Ar)(1)), StrReverse(Dik2(Ar)(2)), StrReverse(Dik2(Ar)(3)), StrReverse(Dik2(Ar)(4)), StrReverse(Dik2(Ar)(5))) '  The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
    Next Ar
Dim v: v = Dik1.items()
' The end result of the above is that we have two 1 D arrays in the items of the dictionaries, one in each. Each element is itself a 1 D array. We find that strangely that  INDEX  seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the  Index(arr(), Rws(), Clms())  way to get out our final range in any order we like.
 Let Range("B2:B" & Em + 1 & "").Value = Application.Index(Dik1.items(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
 Let Range("C2:H" & Em + 1 & "").Value = Application.Index(Dik2.items, Evaluate("=Row(1:" & Em & ")"), Array(6, 5, 4, 3, 2, 1)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
 Range("A1:H1").EntireColumn.AutoFit
End Sub

Sub Dik1Dik2__() '
Dim Ar As Long, Em As Long
 Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 '   The main data from column 1
Dim Dik1 As Object, Dik2 As Object: Set Dik1 = CreateObject("Scripting.Dictionary"): Set Dik2 = CreateObject("Scripting.Dictionary")
    For Ar = 1 To Em ' The main data rows range
     Let Dik1(Ar) = Split(A(Ar, 1), " ", 2, vbBinaryCompare)              '  I am splitting each data into 2 bits, the first is the data  ID  the second is all the rest
     Let Dik2(Ar) = Split(StrReverse(Dik1(Ar)(1)), " ", 6, vbBinaryCompare) '  We are splitting the reversed string, because my second data  CITY  might have a few words, I split the backward string in just enough bits so that the last element is the data  CITY  regardles of how many words are in it
     Let Dik2(Ar) = Array(StrReverse(Dik2(Ar)(5)), StrReverse(Dik2(Ar)(4)), StrReverse(Dik2(Ar)(3)), StrReverse(Dik2(Ar)(2)), StrReverse(Dik2(Ar)(1)), StrReverse(Dik2(Ar)(0))) '  The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
    Next Ar
Dim v: v = Dik1.items()
' The end result of the above is that we have two 1 D arrays in the items of the dictionaries, one in each. Each element is itself a 1 D array. We find that strangely that  INDEX  seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the  Index(arr(), Rws(), Clms())  way to get out our final range in any order we like.
 Let Range("B2:B" & Em + 1 & "").Value = Application.Index(Dik1.items(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
 Let Range("C2:H" & Em + 1 & "").Value = Application.Index(Dik2.items, Evaluate("=Row(1:" & Em & ")"), Array(1, 2, 3, 4, 5, 6)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
 Range("A1:H1").EntireColumn.AutoFit
End Sub

**DocAElstein** · 04-12-2021, 05:12 PM

An extra macro for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=36401
post
https://eileenslounge.com/viewtopic....282498#p282498

Code:

Option Explicit
Sub AL1AL2__() '
Dim Ar As Long, Em As Long
 Let Em = Range("A" & Rows.Count).End(xlUp).Row
Dim A() As Variant: Let A() = Range("A1:A" & Em & "").Value2 '   The main data from column 1
Dim AL1 As Object, AL2 As Object: Set AL1 = CreateObject("System.Collections.ArrayList"): Set AL2 = CreateObject("System.Collections.ArrayList")
    For Ar = 1 To Em ' The main data rows range
     AL1.Add Split(A(Ar, 1), " ", 2, vbBinaryCompare)               '  I am splitting each data into 2 bits, the first is the data  ID  the second is all the rest
     AL2.Add Split(StrReverse(AL1.Item(Ar - 1)(1)), " ", 6, vbBinaryCompare)  '  We are splitting the reversed string, because my second data  CITY  might have a few words, I split the backward string in just enough bits so that the last element is the data  CITY  regardles of how many words are in it
     Let AL2.Item(Ar - 1) = Array(StrReverse(AL2.Item(Ar - 1)(5)), StrReverse(AL2.Item(Ar - 1)(4)), StrReverse(AL2.Item(Ar - 1)(3)), StrReverse(AL2.Item(Ar - 1)(2)), StrReverse(AL2.Item(Ar - 1)(1)), StrReverse(AL2.Item(Ar - 1)(0))) '  The problem with the last line is that all my data words and data numbers are in reverse , so I need to put each data back the correct way around
    Next Ar
' The end result of the above is that we have two 1 D arrays in the Array Lists, one in each.  Each element is itself a 1 D array. We find that strangely that  INDEX  seems to treat such arrays as like 2 D arrays as long as all the 1 D array elements have the same number of elements. This allows us to use the  Index(arr(), Rws(), Clms())  way to get out our final range in any order we like.
 Let Range("B2:B" & Em + 1 & "").Value = Application.Index(AL1.toarray(), Evaluate("=Row(1:" & Em & ")"), Array(1)) ' We only want the first column from V1()
 Let Range("C2:H" & Em + 1 & "").Value = Application.Index(AL2.toarray(), Evaluate("=Row(1:" & Em & ")"), Array(1, 2, 3, 4, 5, 6)) ' We want all the data columns from V2() but need them in the reverse order because we split the reversed string
 Range("A1:H1").EntireColumn.AutoFit
End Sub

**DocAElstein** · 04-23-2021, 09:41 AM

Some extra notes for the solution to this Thread
https://excelfox.com/forum/showthrea...lines-by-codes

This what C2 looks like
_____ Workbook: LisaExSampleFile.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	C
2	655; 661; 663; 665; 667; 6688; 670; 677; 678; 68860-68861; 68864; 68877; 6889; 689; 690; 810; 820

Worksheet: Old

Code:

"655" & ";" & " 661" & ";" & " 663" & ";" & " 665" & ";" & " 667" & ";" & " 6688" & ";" & " 670" & ";" & " 677" & ";" & " 678" & ";" & " 68860" & "-" & "68861" & ";" & " 68864" & ";" & " 68877" & ";" & " 6889" & ";" & " 689" & ";" & " 690" & ";" & " 810" & ";" & " 820"

"655" & ";" & " 661" & ";" & " 663" & ";" & " 665" & ";" & " 667" & ";" & " 6688" & ";" & " 670" & ";" & " 677" & ";" & " 678" & ";" & " 68860" & "-" & "68861" & ";" & " 68864" & ";" & " 68877" & ";" & " 6889" & ";" & " 689" & ";" & " 690" & ";" & " 810" & ";" & " 820"

Code:

'  https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes
'  https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15531&viewfull=1#post15531
Sub AlexSaltColumnB()
Dim WsOld As Worksheet: Set WsOld = Workbooks("LisaExSampleFile.xlsm").Worksheets("Old")
Dim strC2 As String: Let strC2 = WsOld.Range("C2").Value2
' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string
' https://excelfox.com/forum/showthread.php/2302-quot-What%E2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=11015&viewfull=1#post11015
' http://www.eileenslounge.com/viewtopic.php?f=30&t=35732&p=278061#p278061
' https://excelfox.com/forum/showthread.php/2302-quot-What%e2%80%99s-in-a-String-quot-VBA-break-down-Loop-through-character-contents-of-a-string?p=15522&viewfull=1#post15522
' https://pastebin.com/HatYwAAD

 Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strC2) ' A function of mine which i wrote. this analyses all characters in a given text string, in this case a cell in column C
End Sub
'   "655" & ";" & " 661" & ";" & " 663" & ";" & " 665" & ";" & " 667" & ";" & " 6688" & ";" & " 670" & ";" & " 677" & ";" & " 678" & ";" & " 68860" & "-" & "68861" & ";" & " 68864" & ";" & " 68877" & ";" & " 6889" & ";" & " 689" & ";" & " 690" & ";" & " 810" & ";" & " 820"

**DocAElstein** · 04-24-2021, 10:49 AM

In support of this answer
https://excelfox.com/forum/showthrea...5532#post15532

Old Worksheet:

_____ Workbook: Task.xls ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G	H
1	Name	Number	Code	Note	Date	Currency	Min	Max
2	John	43	655; 661; 663; 665; 667; 6688; 670; 677; 678; 68860-68861; 68864; 68877; 6889; 689; 690; 810; 820		03-01-2021	USD	19.83	24.79
3	Steve	43	660; 67833; 67890; 67891; 68183; 699		03-01-2021	USD	17.38	21.73
4	Tom	43	6600; 6990		03-01-2021	USD	17.38	21.73
5	Anthony	43	644; 664; 680; 681; 688; 69981-69982; 69988-69989		03-01-2021	USD	17.38	21.73

Worksheet: Old

New worksheet , Before running macro

_Row\^Col	A	B	C	D	E	F	G	H	I
1	Name	Number	Code	Note	Date	Currency	Min	Max
2

Worksheet: New

New worksheet After running Sub Alex1()

_Row\^Col	A	B	C	D	E	F	G	H
1	Name	Number	Code	Note	Date	Currency	Min	Max
2	John	43	655		03-01-2021	USD	19.83	24.79
3	John	43	661		03-01-2021	USD	19.83	24.79
4	John	43	663		03-01-2021	USD	19.83	24.79
5	John	43	665		03-01-2021	USD	19.83	24.79
6	John	43	667		03-01-2021	USD	19.83	24.79
7	John	43	6688		03-01-2021	USD	19.83	24.79
8	John	43	670		03-01-2021	USD	19.83	24.79
9	John	43	677		03-01-2021	USD	19.83	24.79
10	John	43	678		03-01-2021	USD	19.83	24.79
11	John	43	68860		03-01-2021	USD	19.83	24.79
12	John	43	68861		03-01-2021	USD	19.83	24.79
13	John	43	68864		03-01-2021	USD	19.83	24.79
14	John	43	68877		03-01-2021	USD	19.83	24.79
15	John	43	6889		03-01-2021	USD	19.83	24.79
16	John	43	689		03-01-2021	USD	19.83	24.79
17	John	43	690		03-01-2021	USD	19.83	24.79
18	John	43	810		03-01-2021	USD	19.83	24.79
19	John	43	820		03-01-2021	USD	19.83	24.79
20	Steve	43	660		03-01-2021	USD	17.38	21.73
21	Steve	43	67833		03-01-2021	USD	17.38	21.73
22	Steve	43	67890		03-01-2021	USD	17.38	21.73
23	Steve	43	67891		03-01-2021	USD	17.38	21.73
24	Steve	43	68183		03-01-2021	USD	17.38	21.73
25	Steve	43	699		03-01-2021	USD	17.38	21.73
26	Tom	43	6600		03-01-2021	USD	17.38	21.73
27	Tom	43	6990		03-01-2021	USD	17.38	21.73
28	Anthony	43	644		03-01-2021	USD	17.38	21.73
29	Anthony	43	664		03-01-2021	USD	17.38	21.73
30	Anthony	43	680		03-01-2021	USD	17.38	21.73
31	Anthony	43	681		03-01-2021	USD	17.38	21.73
32	Anthony	43	688		03-01-2021	USD	17.38	21.73
33	Anthony	43	69981		03-01-2021	USD	17.38	21.73
34	Anthony	43	69982		03-01-2021	USD	17.38	21.73
35	Anthony	43	69988		03-01-2021	USD	17.38	21.73
36	Anthony	43	69989		03-01-2021	USD	17.38	21.73

Worksheet: New

**DocAElstein** · 05-07-2021, 10:38 AM

Some further tests in support of this Thread: https://excelfox.com/forum/showthrea...lines-by-codes
this post: https://excelfox.com/forum/showthrea...ll=1#post15539

Some transpose tests using this test macro

Code:

Sub TransposyTests() '  https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15539&viewfull=1#post15539
Dim strTst As String
 Let strTst = "068 069"
Dim arrOutTempC() As String  '
 Let arrOutTempC() = Split(strTst, " ", -1, vbBinaryCompare)
Dim arrOutTempCT1() As Variant, arrOutTempCT2() As Variant, arrOutTempCT3() As Variant
 Let arrOutTempCT1() = Application.Index(arrOutTempC(), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")/row(1:" & UBound(arrOutTempC()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")"))
 Let arrOutTempCT2() = Application.Transpose(arrOutTempC())
Dim Cnt: ReDim arrOutTempCT3(1 To 2, 1 To 1)
    For Cnt = 0 To UBound(arrOutTempC())
     Let arrOutTempCT3(Cnt + 1, 1) = arrOutTempC(Cnt)
    Next Cnt
Stop
End Sub

Running that macro then stopping it before it ends, then highlighting the array variables followed by hitting Shift+F9 will reveal the contents in the Watch Window

http://i.imgur.com/ZZHD5qf.jpg
Attachment 3575

At first glance it looks like the transpose is not the problem

**DocAElstein** · 05-07-2021, 11:03 AM

Continued from last post

If you then look once again at array contents, then you still have what you want : For example in your test data for row with 18; 061-069, this here is what you see.
Attachment 3576
http://i.imgur.com/jbwTQdl.jpg

Once again, the transpose is not the problem

**DocAElstein** · 05-09-2021, 12:08 PM

Another alternative solution for
https://excelfox.com/forum/showthrea...ll=1#post15552

Code:

Sub AlexAlanPascal() '  https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15549#post15549    https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15539&viewfull=1#post15539      https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes
Rem 1 Worksheets info
Dim WsOld As Worksheet, WsNew As Worksheet
 Set WsOld = ThisWorkbook.Worksheets("Old"): Set WsNew = ThisWorkbook.Worksheets("New")
Dim Lr As Long: Let Lr = WsOld.Range("A" & WsOld.Rows.Count & "").End(xlUp).Row  ' https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files-or-single-Excel-File?p=11467&viewfull=1#post11467
Rem 2
Dim ACel As Range, TLeft As Long: Let TLeft = 2  ' This variable holds the position of the next section in the  New  worksheet
    For Each ACel In WsOld.Range("A2:A" & Lr & "") '   main loop going down all name cells ======
    Dim AName As String: Let AName = ACel.Value2
    Dim CVal As String: Let CVal = ACel.Offset(0, 2).Value2 & ";"  ' I need the extra  ;  or otherwise I might miss the last number range ( number range is something like  45-48 ) if there is one,  because I look for the  ;  in order to determine where that number rang ends
    ' 2b modifying any  3-5  type data
    Dim PosDsh As Long: Let PosDsh = InStr(1, CVal, "-", vbBinaryCompare)
        Do While PosDsh > 0 '  Position of the dash will be returned as  0  by the  Instr  function if  the Instr  function cannot find a next dash.  Also my coding below might retun me  -1  at this line ---###
      
        Dim StrtN As String, StpN As String '  I use these variables initially for the position of the number  and then the actual number
         Let StrtN = InStrRev(Left(CVal, PosDsh), " ", -1, vbBinaryCompare) + 1
         Let StrtN = Mid(CVal, StrtN, PosDsh - StrtN)
         Let StpN = InStr(PosDsh, CVal, ";", vbBinaryCompare)
         Let StpN = Mid(CVal, PosDsh + 1, (StpN - 1) - PosDsh)
        Dim NRng As String
       
        Let NRng = StrtN & "-" & StpN
        Dim Cnt As Long, Padding As Long
         Let Padding = Len(StrtN)
            For Cnt = StrtN To StpN Step 1
            Dim NRngMod As String
'            Dim FrstSym As String
'             Let FrstSym = Left(NRng, 1)
'                If FrstSym = 0 Then
'                Let NRngMod = NRngMod & "0" & Cnt & "; "
'                Else
'                Let NRngMod = NRngMod & Cnt & "; "
'                End If
             Let NRngMod = NRngMod & Format(Cnt, Application.Rept(0, Padding)) & "; "
            Next Cnt
         Let NRngMod = Left(NRngMod, Len(NRngMod) - 2) ' I don't need the last 2 characters of   "; "
         Let CVal = Replace(CVal, NRng, NRngMod & "|", 1, 1, vbBinaryCompare) ' I haver a temporary  "|"  to indicate the end of the last modified bit
         Let PosDsh = InStr((InStr(1, CVal, "|", vbBinaryCompare)), CVal, "-", vbBinaryCompare) - 1 ' because I start looking at just after the last modified part, this will return me the position of the next one, ( or 0 if none is found )   -1 is because I am reducing the length by 1 in the next code line    ---###
         Let CVal = Replace(CVal, "|", "", 1, 1, vbBinaryCompare)
        
         Let NRngMod = ""  ' rest this variable for next use '
        Loop
        
    ' 2c Modified column C output
     Let CVal = Replace(CVal, ";", "", 1, -1, vbBinaryCompare) '  I don't want any  ;  in the modified list
    Dim arrOutTempC() As String  '
     Let arrOutTempC() = Split(CVal, " ", -1, vbBinaryCompare)
    Dim arrOutTempCT() As Variant
     Let arrOutTempCT() = Application.Index(arrOutTempC(), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")/row(1:" & UBound(arrOutTempC()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrOutTempC()) + 1 & ")"))
    ' 2d All  New  column output
     Let WsNew.Range("C" & TLeft & ":C" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = arrOutTempCT()
     Let WsNew.Range("A" & TLeft & ":A" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Value2  ' Name
     Let WsNew.Range("B" & TLeft & ":B" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 1).Value2 ' Number
     Let WsNew.Range("E" & TLeft & ":E" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 4).Value2  ' Date
     Let WsNew.Range("E" & TLeft & ":E" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").NumberFormat = "m/d/yyyy"
     Let WsNew.Range("F" & TLeft & ":F" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 5).Value2  ' Currency
     Let WsNew.Range("G" & TLeft & ":G" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 6).Value2  ' Min
     Let WsNew.Range("H" & TLeft & ":H" & TLeft + UBound(arrOutTempCT(), 1) - 1 & "").Value2 = ACel.Offset(0, 7).Value2  ' Max
     
     Let TLeft = TLeft + UBound(arrOutTempCT(), 1)  '  this should adjust our top left cell for next range of  new  columns
    Next ACel  '  '   main loop going down all name cells   =========
    
End Sub

**DocAElstein** · 08-11-2021, 09:34 AM

In support of this Thread
https://excelfox.com/forum/showthrea...gure-(cricket)

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Player 1	Overs	Maiden	Runs	Wickets	Bwl Ave	Econ	Wides	No Balls	balls	strike rate	5w	BBI
2	Match 1			1	1	1.00	n/a			0	0.00
3	Match 2			1	1	1.00	n/a			0	0.00
4	Match 3			1	2	0.50	n/a			0	0.00
5	Match 4			1	2	0.50	n/a			0	0.00
6	Match 5			70	3	23.33	n/a			0	0.00
7	Match 6			1	1	1.00	n/a			0	0.00
8	Match 7			1	1	1.00	n/a			0	0.00
9	Match 8			1	1	1.00	n/a			0	0.00
10	Match 9			32	3	10.67	n/a			0	0.00
11	Match 10			1	1	1.00	n/a			0	0.00
12	Match 11			1	1	1.00	n/a			0	0.00
13	Match 12			1	1	1.00	n/a			0	0.00
14	Match 13			1	1	1.00	n/a			0	0.00
15	Match 14			1	1	1.00	n/a			0	0.00
16	Match 15			1	1	1.00	n/a			0	0.00
17	Match 16			1	1	1.00	n/a			0	0.00
18	Match 17			1	1	1.00	n/a			0	0.00
19	Match 18			1	1	1.00	n/a			0	0.00
20	Match 19			1	1	1.00	n/a			0	0.00
21	Match 20			1	1	1.00	n/a			0	0.00
22	Player 1	0	0	120	26	4.62	0.00	0	0	0	0.00	0
23
24	Player 2	Overs	Maiden	Runs	Wickets	Bwl Ave	Econ	Wides	No Balls	balls	strike rate	5w
25	Match 1					n/a	n/a			0	n/a
26	Match 2					n/a	n/a			0	n/a

Worksheet: Sheet3

A basic formula to get a maximum value:

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )

_Row\^Col	N
8	MxD
9	3

Worksheet: Sheet3

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )

_Row\^Col	N
8	MxD
9	=MAX(E2:E21)

Worksheet: Sheet3

**DocAElstein** · 08-11-2021, 09:34 AM

.... test post for later

Hi prkhan56
Welcome to ExcelFox

I am sorry you have had no reply.
We don’ t have many Word experts popping by excelfox much these days.

I don’t know much about Word VBA, and have never done anything with images so I don’t really understand what is wanted here. I don’t see the relation to images , pictures , “moving images”.

I have manipulated Word files with some VBA code working from Excel. Sometime my files were saved as extension type .htm – those files were normal word files with a lot of text and tables in them and the coding handled them the same as any files of extension type .doc or .docx or .docm

So I am not really so well qualified to help on what you want, but I will have a go…..

I took a quick look at this macro , Sub GetPicturesFromWordDocument() ,
I have rewritten, or rather just re arranged slightly the macro and made some minor changes as I went along and added some 'comments . I did this to help me understand what is going on.
( Here is my version: https://excelfox.com/forum/showthrea...ll=1#post15614 )

Here is a walk through my version:
For the sake of explanation, let me assume that when you run this macro you have a Word document open , which is active, and it has the name MyDoc.doc

The macro stores the current active document name ( but without the extension type) in strDocumentName. So if the active document was MyDoc.doc , then strDocumentName will have MyDoc in it.
We also store the path to the current active document in strPath
The macro seems to save the active document under its existing name, at the existing place, but with the extension type changed to .htm , so you would have then the active document, if it was MyDoc.doc now saved as MyDoc.htm - …. It is not clear to me why that is being done??

The macro makes a folder, MovedToHere in the same place as where the current active document is. I have slightly modified this code line, to prevent it erroring if the folder already exists: It only makes the folder if the folder does not exist. - If you try to make a folder when it already exists, then that would chuck up an error

__ The main outer loop === is doing the following:
It is looping 4 times, going through all your file extension types, .png .jpeg .jpg and .bmp. ( The loop control variable, lngLoop , is going from 0 To 3 )
__ For each file extension type it is looking for files which are in a folder which, using the same example, would have a name like MyDoc_files . That folder is looked for at the same path as the current active document.
So for example, the first loop is looking for files of the extension type .png in that folder
____ The purpose of the Do While __ Loop _ loop is to keep going while you still find files of the extension type currently being looked for. ( The use of Dir on its own, without any bracket ( ) stuff tells VBA to look again for the next file of the same type and in the same place that it looked the last time )
____ Each of the files you find gets copied to folder, MovedToHere and has its name modified a bit to have the text "New " added at the start, like for example, Filex.png would become New Filex.png ( Note: actually we are not really copying – we are moving – the original file gets effectively deleted )

Once we have finished doing all that copying, we close the current active document. It is not clear to me why that is being done. In particular it’s not clear to me why it is done at this point. We could have closed it immediately after we created it, since we have done nothing with it since creating it

We now open the original file we had open at the start of running the macro. Its not clear to me why we do that, other than maybe to get back to having the same file open and active that we had when we started running the macro.

Now we go on to killing ( deleting ) a few things.
The code line Kill strPath & "" & strDocumentName & ".htm*" does not error for me. I can not see why it should, since it is trying to delete all files of the extension type .htm , html etc. in the folder where we made like our MyDoc.htm
Since we should have at least that one file there, MyDoc.htm , then that at least that is there to be deleted
The next code line, Kill strPath & "" & strDocumentName & "_files\*.*" could error , if, for example, you had only had files of the type .png .jpeg .jpg or .bmp originally in that folder with the name like MyDoc_files . The reason for that is because the VBA Name statement renames a file, in other words it moves , or in other words it copies the file to somewhere and then deletes the original. So effectively it will be removing all files of the type .png .jpeg .jpg or .bmp from that folder.
So I have modified that code line so that it only tries to delete files if there are any files there to delete.
I expect the reason the code line is there is so that the next code line works. – This next code line, RmDir strPath & "" & strDocumentName & "_files" , tries to delete the original folder, and that code line would error if any files were in that folder.

The last few lines are not needed in VBA. Those code lines were considered good practice in programming earlier, I think. Possibly they may have sometimes been needed previously. I am not sure.

I am not sure if I can help much further, since I cannot reproduce your error. The macro version of mine ( Here: https://excelfox.com/forum/showthrea...ll=1#post15614 ) does not error, but I may have missed something due to my lack of experience with Word VBA.

Originally Posted by prkhan56

I want to fix this code ...... Can someone fix this issue ...

I cant fix the code for you , because I cannot see the problem with it. But I am also not 100% sure of why some things are being done in the macro.

Originally Posted by prkhan56

.....and also amend to run on all the sub folders.....

I don’t think you can amend a macro like this one to do that. The reason for me saying that is that the main process we are using to look at, and get at files, is the Dir function, and in particular the code line of Dir within a loop. This restricts us to one “folder level”.
We are using a fairly simple macro, like the one you are using.
Its this sort of thing: https://excelfox.com/forum/showthrea...ull=1#post6175
To look at sub folders we would usually use a different macro type, one which uses recursion. This sort of thing:
https://excelfox.com/forum/showthrea...ll=1#post10420
https://excelfox.com/forum/showthrea...ll=1#post10421
https://excelfox.com/forum/showthrea...ll=1#post10422

As you can see, that is a rather complex thing. Depending on your knowledge of VBA, that could be a rather time consuming thing to get across to you, especially as we don’t have the simpler issue fixed of why you are getting the error in the simpler macro

I expect it could take me a long time to help you further. I am busy all this week, and could take another look for you next week.

Alternatively you might want to try one of the other forums where a lot more people usually are, and certainly more people clued up on Word VBA
Here a couple of places :
https://www.excelforum.com/word-programming-vba-macros/
http://www.eileenslounge.com/viewforum.php?f=26

Please note that most forums have what they call a “cross posting rule”. This means that you should tell everyone everywhere about where else you have posted the same question.
So for example you should pass on these URL link to your questions here
https://excelfox.com/forum/showthread.php/2760-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15605#post15605
https://excelfox.com/forum/showthread.php/2761-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15613#post15613
One last tip here: If you are posting for the first time at some forums then a spam filter will prevent you posting those links. To get over that you need to disguise them when posting. You could add some spaces like this
h t t p s:/ /excelfox . com/forum/showthread.php/2760-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15605#post15605
h t t p s:/ /excelfox . com/forum/showthread.php/2761-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15613#post15613
Or alternatively try fooling the filter by posting using some BB code for black color to disguise the link – that way the filter does not see the link, but it comes out in the final post as you want it
htt[color=Black]p[/color]s:[color=Black]/[/color]/excelfox[color=Black].c[/color]om/forum/showthread.php/2760-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15605#post15605
htt[color=Black]p[/color]s:/[color=Black]/[/color]excelfox[color=Black].c[/color]om/forum/showthread.php/2761-Get-Pictures-from-Word-Documents-in-All-Sub-Folders?p=15613#post15613

Alan