Tests Copying pasting Cliipboard issues [Archive] - Page 2 - Excel, Access, PowerPoint and Word VBA Macro Automation Help

DocAElstein

04-28-2020, 01:19 PM

Notes for this Post
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE

In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv ........_
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEACCEQ
1182
1193
1151.7
1190.45
1156.6
22
11.566
116815
1168.166

3NSEADANIENTEQ
137.15
140.55
134.1
140.5
134.65
25
1.3465
13595
135.9965

4NSEADANIPORTSEQ
273.95
276.95
269.55
277.6
270.65
15083
2.7065
27335
273.3565

5NSEADANIPOWEREQ
32.3
32.35
30.45
32.45
30.65
17388
0.3065
3095
30.9565

6NSEAMARRAJAEQ
555
555
529.25
557.85
532.1
100
5.321
5374
537.21

7
Worksheet: 1-Sheet1 3Mai

_____ Workbook: 3.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
6AGTT

2

3
Worksheet: Sheet1

_..........
suppose 1.xls has data in 5 rows then copy 3.xlsx first row of sheet3 and paste it to 2.csv 5 times

_____ Workbook: 2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
6AGTT

2NSE
6AGTT

3NSE
6AGTT

4NSE
6AGTT

5NSE
6AGTT

6
Worksheet: 2

DocAElstein

05-03-2020, 09:36 PM

macro solution for last post and solution for
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13185&viewfull=1#post13185

In the macro I have done for you , there are two possibilities.
You only need one
You can choose
' 2b)(i) Relative formula references ...

' 2b)(i) Relative formula references ... https://teylyn.com/2017/03/21/dollarsigns/#comment-191
Ws2.Cells.NumberFormat = "General" ' May be needed to prevent formulas coming out as test =[3.xlsx]Sheet1!$A$1
Let rngOut.Value = "='[3.xlsx]" & Ws3.Name & "'!A$1"
Let rngOut.Value = rngOut.Value ' Change Formulas to values
Let rngOut.Value = Evaluate("If({1},SUBSTITUTE(" & rngOut.Address & ", ""0"", """"))") ' https://excelribbon.tips.net/T010741_Removing_Spaces
' Or
'' 2b)(ii) Copy paste
'Dim rngIn As Range
' Set rngIn = Ws3.Range("A1:" & Lc3Ltr & "1")
' rngIn.Copy
' rngOut.PasteSpecial Paste:=xlPasteValues ' understanding Paste across ranges of different size to Copy range : https://excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441
OR
' 2b)(ii) Copy Paste

' 2b)(i) Relative formula referrences ... https://teylyn.com/2017/03/21/dollarsigns/#comment-191
' Ws2.Cells.NumberFormat = "General" ' May be needed to prevent formulas coming out as test =[3.xlsx]Sheet1!$A$1
' Let rngOut.Value = "='[3.xlsx]" & Ws3.Name & "'!A$1"
' Let rngOut.Value = rngOut.Value ' Change Formulas to values
' Let rngOut.Value = Evaluate("If({1},SUBSTITUTE(" & rngOut.Address & ", ""0"", """"))") ' https://excelribbon.tips.net/T010741_Removing_Spaces
' Or
' 2b)(ii) Copy Paste
Dim rngIn As Range
Set rngIn = Ws3.Range("A1:" & Lc3Ltr & "1")
rngIn.Copy
rngOut.PasteSpecial Paste:=xlPasteValues ' understanding Paste across ranges of different size to Copy range : https://excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441

Sub Step14() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=34508 (zyxw123) https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13182#post13182
Rem 1 Worksheets info
Dim w1 As Workbook, w2 As Workbook, w3 As Workbook
Set w1 = Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xlsx")
Set w2 = Workbooks("2.csv") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\document\2.csv")
Set w3 = Workbooks("3.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\files\3.xlsx")
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Set Ws1 = w1.Worksheets.Item(1)
Set Ws2 = w2.Worksheets.Item(1)
Set Ws3 = w3.Worksheets.Item(1)
Dim Lc3 As Long, Lenf1 As Long, Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Let Lc3 = Ws3.Cells.Item(1, Ws3.Columns.Count).End(xlToLeft).Column
Dim Lc3Ltr As String
Let Lc3Ltr = CL(Lc3)
Rem 2 ' In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv
Let Lenf1 = Lr1 - 1 ' 1.xls first row has headers so dont count that
' 2a)
Dim rngOut As Range: Set rngOut = Ws2.Range("A1:" & Lc3Ltr & Lenf1 & "")
' 2b)(i) Relative formula referrences ... https://teylyn.com/2017/03/21/dollarsigns/#comment-191
Ws2.Cells.NumberFormat = "General" ' May be needed to prevent formulas coming out as test =[3.xlsx]Sheet1!$A$1
Let rngOut.Value = "='[3.xlsx]" & Ws3.Name & "'!A$1"
Let rngOut.Value = rngOut.Value ' Change Formulas to values
Let rngOut.Value = Evaluate("If({1},SUBSTITUTE(" & rngOut.Address & ", ""0"", """"))") ' https://excelribbon.tips.net/T010741_Removing_Spaces
' Or
' 2b)(ii) Copy Paste
Dim rngIn As Range
Set rngIn = Ws3.Range("A1:" & Lc3Ltr & "1")
rngIn.Copy
rngOut.PasteSpecial Paste:=xlPasteValues ' understanding Paste across ranges of different size to Copy range : https://excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441

Rem 3
' w1.Close
' w2.Save
' Let Application.DisplayAlerts = False
' w2.Close
' Let Application.DisplayAlerts = True
' w3.Close
'
End Sub

' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

DocAElstein

05-05-2020, 11:48 AM

In support to answer to this Thread
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE

from about here:
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13193&viewfull=1#post13193

Before csv file link https://drive.google.com/open?id=1MF...s6EWCLjkblGxfo
Before csv.jpg : https://imgur.com/NLryZml
2900

After runing macro csv link https://drive.google.com/open?id=1V_...S63idSd5zlDcVX
After csv.JPG : : https://imgur.com/IzaxRrh
2901

Analysing what we have before and after
To get the single string of what is in the file, from here , https://www.homeandlearn.org/open_a_text_file_in_vba.html https://www.homeandlearn.org/write_to_a_text_file.html ,

I use the below macro to analyse the supplied from vixer google drive share file for Before, ( Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) is in next post )

' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13208&viewfull=1#post13208
Sub TestieCSVstringBefore()
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\" & "2 Before.csv" ' From vixer : https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13193&viewfull=1#post13193 Before csv file link https://drive.google.com/file/d/1MFIgUUiH0QPO1oWpDms6EWCLjkblGxfo/view Before csv.jpg : https://imgur.com/NLryZml
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

End Sub

After running the above macro I get this analysis:

vbCr & vbLf

_._________________________________________
I repeat the same for the supplied After file.

' Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As 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 ' 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
Sub TestieCSVstringAfter()
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\" & "2.csv" ' From vixer : https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13193&viewfull=1#post13193 After runing macro csv link https://drive.google.com/file/d/1V_85p1O4lV4RvqHw1dS63idSd5zlDcVX/view After csv.JPG : : https://imgur.com/IzaxRrh
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

End Sub

Here is the result

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
vbCr & vbLf
It is a single long string

Here the same again , differently shown, just for clarity. But remember, it is actually a single long string.

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf &
"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf &
"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf &
"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf &
"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf

Or like
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf
"NSE" vbTab vbTab "6" vbTab vbTab vbTab "A" vbTab vbTab vbTab vbTab vbTab "GTT" vbCr vbLf

DocAElstein

05-05-2020, 12:45 PM

Function required for last post

' 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
Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) '
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make Temporary Sheets, if not already there, in Current Active Workbook, for a simple list of all characters, and for pasting the string into worksheet cells
'1a)(i) Full list of characters worksheet
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but iin general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim ws As Worksheet '
Set ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
ws.Activate: ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1a(ii) Worksheet to paste out string into worksheet cells
If Not Evaluate("=ISREF(" & "'" & "StrIn|WtchaGot" & "'!Z78)") Then
Set Wb = ActiveWorkbook
Wb.Worksheets.Add Before:=Wb.Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = ActiveSheet
Ws1.Activate: Ws1.Cells(1, 1).Activate
Let Ws1.Name = "StrIn|WtchaGot"
Else
Set Ws1 = ThisWorkbook.Worksheets("StrIn|WtchaGot")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. ) https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 40)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop============================================== ==========================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
'SirNirios
If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a "normal" character
If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]") Then ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
Else
End If
Else
End If
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' ' 2a)(ii)_2
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & " ' I actuall would write manually in this case like vbCr &
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case vbNewLine
Let WotchaGot = WotchaGot & "vbNewLine & "
Case """" ' This is how to get a single " No one is quite sure how this works. My theory that, is as good as any other, is that syntaxly """" or " """ or """ " are accepted. But in that the """ bit is somewhat strange for VBA. It seems to match the first and Third " together as a valid pair but the other " in the middle of the 3 "s is also syntax OK, and does not error as """ would because of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the first and Third as a concluding string pair. All is well except that the second " is captured within a accepted enclosing pair made up of the first and third " At the same time the 4th " is accepted as a final concluding " paired with the second which it is using but at the same time now isolated from.
Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & " ' The reason why "" "" would not work is that at the end of the "" the next empty character signalises the end of a string pair, and only if it saw a " would it keep checking the syntax rules which then lead in the previous case to the situation described above.
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
' 2a)(iii)
Case Else
If AscW(Caracter) < 256 Then
Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
Else
Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
End If
'Let CaseElse = Caracter
End Select
End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
'2b) A 2 column Array for convenience of a list
Let arrWotchaGot(Cnt + 1, 1) = Cnt & " " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = AscW(Caracter) ' +1 for header
Next Cnt ' ========Main Loop============================================== ===================================
'2c) Some tidying up
If WotchaGot <> "" Then
Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
' The next bit changes like this "Lapto" & "p" to "Laptop" You might want to leave it out ti speed things up a bit
If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) ' Changes like this "Lapto" & "p" to "Laptop"
Else
End If
Else
End If
Rem 3 Output
'3a) String
'3a)(i)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
'3a)(ii)
Ws1.Activate: Ws1.Cells.Item(1, 1).Activate
Let Ws1.Range("A1").Value = strIn
Let Ws1.Range("B1").Value = WotchaGot
'3b) List
Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next If this prevents the first column beine taken as 0 for an empty worksheet
ws.Activate: ws.Cells.Item(1, 1).Activate
If Not ws.Range("A1").Value = "" Then Let NxtClm = ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
Let ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
ws.Cells.Columns.AutoFit
End Sub
'

DocAElstein

05-05-2020, 02:39 PM

Next solution attempt for this:
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13219&viewfull=1#post13219

Do not put a code line in the macro to open 2.csv!

Sub Step14_DogShit() ' https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13219&viewfull=1#post13219
Rem 1 Worksheets info
Dim w1 As Workbook, w2 As Workbook, w3 As Workbook
Set w1 = Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xlsx")
' Do Not open 2.csv ' Set w2 = Workbooks("2.csv") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\document\2.csv")
Set w3 = Workbooks("3.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\files\3.xlsx")
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
Set Ws1 = w1.Worksheets.Item(1)
' Set Ws2 = w2.Worksheets.Item(1)
Set Ws3 = w3.Worksheets.Item(1)
Dim Lc3 As Long, Lenf1 As Long, Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
' Let Lc3 = Ws3.Cells.Item(1, Ws3.Columns.Count).End(xlToLeft).Column
' Dim Lc3Ltr As String
' Let Lc3Ltr = CL(Lc3)
Rem 2 ' In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv
Let Lenf1 = Lr1 - 1 ' 1.xls first row has headers so dont count that
' 2a) get range to be put into dog shit files
Dim arrIn() As Variant: Let arrIn() = Ws3.Range("A1:K1").Value
' 2b) make a string fow a row, including a dog shit Tab seperator
Dim cnt
For cnt = 1 To UBound(arrIn(), 2) ' Column count in worksheet 3 row 1
Dim strLine As String
Let strLine = strLine & arrIn(1, cnt) & vbTab
Next cnt
Let strLine = Left(strLine, (Len(strLine) - 1)) ' Take off last Tab
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strLine) ' "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT"
' 2c) repeat string to include (and include line breaks) to make complete string for do shit text files
For cnt = 1 To Lenf1 ' row count of our dog shit text files
Dim strTotalFile As String
Let strTotalFile = strTotalFile & strLine & vbCr & vbLf
Next cnt
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strTotalFile ) ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13218&viewfull=1#post13218

Rem 4 make dogshit files
' 4a) Dog Shit text
Dim Highway1 As Long: Let Highway1 = FreeFile(0) 'range 1 – 255, inclusive - next free
Open ThisWorkbook.Path & "\" & "DogShit.txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, strTotalFile
Close #Highway1
' 4b) 2.csv
Dim Highway2 As Long: Let Highway2 = FreeFile(0) 'range 1 – 255, inclusive - next free
Open ThisWorkbook.Path & "\" & "2.csv" For Append As #Highway2 ' Will be made if not there
Print #Highway2, strTotalFile
Close #Highway2

Rem ....
' w1.Close
' w2.Save
'' Let Application.DisplayAlerts = False
'' w2.Close
'' Let Application.DisplayAlerts = True
' w3.Close
'
End Sub

DocAElstein

05-05-2020, 02:43 PM

Some Development results from running macro from last post

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT"

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf & "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strLine)

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT"

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(strTotalFile )

"NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
& "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
& "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
& "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT" & vbCr & vbLf
& "NSE" & vbTab & vbTab & "6" & vbTab & vbTab & vbTab & "A" & vbTab & vbTab & vbTab & vbTab & vbTab & "GTT"
& vbCr & vbLf

DocAElstein

05-07-2020, 01:27 PM

In support of these Post
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13246&viewfull=1#post13246
http://www.eileenslounge.com/viewtopic.php?p=268627#p268627

These are all text Files. The macro in the next post ( https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13248&viewfull=1#post13248 ) will make them
XXXXSeperatedValuesTextFiles.JPG : https://imgur.com/A2IebLK

Comma Seperated values
(Sometimes called English Comma Seperated Values )

zyxw123,jhas,,rider,roger,anjus,sumanjjj

Leonardo,umpsbug,kinjals,,tinamishra,kinjal124,Wig Wam

Share ‘CommaSeperatedValues.txt’ : https://app.box.com/s/qcjpeu0vt875513gqawmtoufeba3xb28
Share ‘CommaSeperatedValues.csv’ : https://app.box.com/s/w2barpwasveltam4lutjwijks0zft0vq

Tab Seperated Values

zyxw123jhasriderrogeranjussumanjjj

Leonardoumpsbugkinjalstinamishrakinjal124WigWam

Share ‘TabSeperatedValues.csv’ : https://app.box.com/s/ukgxcmxj8xhmy0gzvw5269zyjdmun28g
Share ‘TabSeperatedValues.txt’ : https://app.box.com/s/d24blwuejfixh9ofhrg387nbadxjvu15

NMOD Seperated Values

zyxw123NMODjhasNMODNMODriderNMODrogerNMODanjusNMOD sumanjjj

LeonardoNMODumpsbugNMODkinjalsNMODNMODtinamishraNM ODkinjal124NMODWigWam

Share ‘NMODSeperatedValues.csv’ : https://app.box.com/s/ohxqrao160vapx5jozhx7ejc4t70v1wl
Share ‘NMODSeperatedValues.txt’ : https://app.box.com/s/46p14u9rfwvve0s4yv01zyy34f6qhmmz

Semi Colon Seperated Values
(Sometimes called German Comma Seperated values)

zyxw123;jhas;;rider;roger;anjus;sumanjjj

Leonardo;umpsbug;kinjals;;tinamishra;kinjal124;Wig Wam

Share ‘SemiColonSeperatedValues.csv’ : https://app.box.com/s/kvqqfsjaebzj684rw8n0u1v4hqfi3hea
Share ‘SemiColonSeperatedValues.txt’ : https://app.box.com/s/qojzd9ogwgg2d2unh2k8dkvwzdpgh84e

GollyWobbles Seperated Values

zyxw123GollyWobblesjhasGollyWobblesGollyWobblesrid erGollyWobblesrogerGollyWobblesanjusGollyWobblessu manjjj

LeonardoGollyWobblesumpsbugGollyWobbleskinjalsGoll yWobblesGollyWobblestinamishraGollyWobbleskinjal12 4GollyWobblesWigWam

Share ‘GollyWobblesSeperatedValues.txt’ : https://app.box.com/s/d0pktg8fadbkl8nfwnodfyle5766lghx
Share ‘GollyWobblesSeperatedValues.csv’ : https://app.box.com/s/5xbiy0wrc05txaofr7qknpot7cb3qdo3

Excel File With Wrong Extension

_____ Workbook: ExcelFileWithWrongExtension.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1zyxw123jhasriderrogeranjussumanjjj

2Leonardoumpsbugkinjalstinamishrakinjal124fxe632

3
Worksheet: Tabelle1

Share ‘ExcelFileWithWrongExtension.csv’ : https://app.box.com/s/esxlg0ovoux4gk29zxgklwog6zz6b7s1

DocAElstein

05-07-2020, 01:27 PM

In support of these Post
http://www.eileenslounge.com/viewtopic.php?f=30&t=34629

These are all text Files. The macro in this post ( https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13248&viewfull=1#post13248 ) will make them
XXXXSeperatedValuesTextFiles.JPG : https://imgur.com/A2IebLK
PipeSeperatedValuesTextFiles.JPG : https://imgur.com/Y9676cg

Comma Seperated values
(Sometimes called English Comma Seperated Values )

zyxw123,jhas,,rider,roger,anjus,sumanjjj

Leonardo,umpsbug,kinjals,,tinamishra,kinjal124,Wig Wam

Share ‘CommaSeperatedValues.txt’ : https://app.box.com/s/qcjpeu0vt875513gqawmtoufeba3xb28
Share ‘CommaSeperatedValues.csv’ : https://app.box.com/s/w2barpwasveltam4lutjwijks0zft0vq

Pipe Seperated Text Files

zyxw123|jhas||rider|roger|anjus|sumanjjj

Leonardo|umpsbug|kinjals||tinamishra|kinjal124|Wig Wam

Share ‘PipeSeperatedValues.txt’ : https://app.box.com/s/47eo2pmeqlmnjj5h9hlxog8ts47nlgj7
Share ‘PipeSeperatedValues.csv’ : https://app.box.com/s/o7zculmorhyys3r9b6hwwuc3wry1mr6p

DocAElstein

05-07-2020, 02:05 PM

In support of this Post
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13246&viewfull=1#post13246

Run the macro below, Sub XXXXXSeperatedValuesTextFiles() ,
It will make text files in the same folder as the folder in which the macro is run in.
( The macro is also in the shared File, XXXXXSeperatedValues.xlsm )
XXXXSeperatedValuesTextFiles.JPG : https://imgur.com/A2IebLK

The text files are shown in the last post https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13247&viewfull=1#post13247

Option Explicit
Sub XXXXXSeperatedValuesTextFiles() ' https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13246#post13246
Call Make____SeperatedValuesTextFiles("CommaSeperatedValues", ",") ' make CSV files ( Comma Seperated Values Files )
Call Make____SeperatedValuesTextFiles("TabSeperatedValues", vbTab) ' make Tab Seperated Values Files
Call Make____SeperatedValuesTextFiles("NMODSeperatedValues", "NMOD") ' make NMOD Seperated Values Files
Call Make____SeperatedValuesTextFiles("SemiColonSeperatedValues", ";") ' make ; Seperated Values Files ( sometimes called german Comma seperated files )
Call Make____SeperatedValuesTextFiles("GollyWobblesSeperatedValues", "GollyWobbles") ' make GollyWobbles Seperated Values Files
Call Make____SeperatedValuesTextFiles("PipeSeperatedValues", "|") ' make Pipe Seperated Values Files
End Sub

Sub Make____SeperatedValuesTextFiles(ByVal Filname As String, Seprator As String)
' Make long string for text file
Dim strTotalFile As String
Let strTotalFile = MakeA____SeperatedValuesTextFile(Seprator)
' .txt Text File
Dim Highway1 As Long: Let Highway1 = FreeFile(0) 'range 1 – 255, inclusive - next free
Open ThisWorkbook.Path & "\" & Filname & ".txt" For Append As #Highway1 ' Will be made if not there
Print #Highway1, strTotalFile
Close #Highway1

' .csv Text File
Dim Highway2 As Long: Let Highway2 = FreeFile(0) 'range 1 – 255, inclusive - next free
Open ThisWorkbook.Path & "\" & Filname & ".csv" For Append As #Highway2 ' Will be made if not there
Print #Highway2, strTotalFile
Close #Highway2

End Sub
Function MakeA____SeperatedValuesTextFile(ByVal Seprator As String) As String
Rem 1 Rows
Dim AvinashNamesRow1() As Variant, AvinashNamesRow2() As Variant
Let AvinashNamesRow1() = Array("zyxw123", "jhas", "", "rider", "roger", "anjus", "sumanjjj")
Let AvinashNamesRow2() = Array("Leonardo", "umpsbug", "kinjals", "", "tinamishra", "kinjal124", "fxe632")
Rem 2 make single string for text files
Dim strOut As String
Let strOut = Join(AvinashNamesRow1(), Seprator) & vbCr & vbLf & Join(AvinashNamesRow2(), Seprator) & vbCr & vbLf
Let MakeA____SeperatedValuesTextFile = strOut
End Function

Ref
https://excelfox.com/forum/showthread.php/647-Importing-a-csv-File-to-a-range/page3

XXXXXSeperatedValues.xlsm : https://app.box.com/s/jvlu048tkg0rjw7xi4c4r838abw1z7bi

sandy666

05-07-2020, 02:21 PM

ADHahdhdh

do ya have : Attention deficit hyperactivity disorder (ADHD) ??? ;)

DocAElstein

05-07-2020, 02:29 PM

do ya have : Attention deficit hyperactivity disorder (ADHD) ??? ;)
Probably :)
it is fixer's fault - he is driving me mad!

sandy666

05-07-2020, 02:34 PM

easy, easy, this is a patience test %D

DocAElstein

05-07-2020, 02:47 PM

It is character building.
Actually, you are good at geussing what he wants...
I will post just once more now in the main Thread , and then go and break some more rocks for relaxation for the rest of the day..
C ya tomorrrow
:)

DocAElstein

05-08-2020, 12:57 PM

Another attempt to geuss what fixer is askig for from here:
https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13256&viewfull=1#post13256

Sub OpenTxtFiles_ValuesToBeSeperatedIntoExcelCells()
' Comma seperated values text files
Call OpenA____SeperatedValuesTextFile("CommaSeperatedValues.csv", ",")
Call OpenA____SeperatedValuesTextFile("CommaSeperatedValues.txt", ",")
End Sub

Sub OpenA____SeperatedValuesTextFile(ByVal Filname As String, ByVal Seprator As String)
Rem 1 Get text file as long string.
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\" & Filname '
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
Rem 2 Put values in Excel
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Ws1.Cells.ClearContents
'2b) Split Total File text into a 1 Dimensional array into rows
Dim RwTxt() As String: Let RwTxt() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim Clms() As String
Let Clms() = Split(RwTxt(0), Seprator, -1, vbBinaryCompare) ' This will be the first row of data. Here we are doing it just to gat the column count. In the loop below, we will use it for every row, including initially this first row. We need it below to allow us to access each value seperately seperated via the seprator, seprator
Dim HedClmsCnt As Long: Let HedClmsCnt = UBound(Clms) + 1 ' +1 is required , as , by default , a 1Dimensional array from split has first element indicie of 0 , so Ubound will be 1 less than the number of elements
Dim arrOut() As String ' I must make this dynamic, since i must use the TReDim method to size it. This is because the Dim statement will not accept variables or non static values: It omly accepts actual integer hard coded numbers
ReDim arrOut(1 To UBound(RwTxt) + 1, 1 To HedClmsCnt) ' +1 is required , as , by default , a 1Dimensional array from split has first element indicie of 0 , so Ubound will be 1 less than the number of elements
Dim RwCnt As Long
For RwCnt = 0 To UBound(RwTxt)
'2c) Split each row into seperated values
Let Clms() = Split(RwTxt(RwCnt), Seprator, -1, vbBinaryCompare)
Dim ClmCnt As Long
If Not UBound(Clms()) = -1 Then ' This might be the case fo extra rows in the text file with no seperators in s
For ClmCnt = 1 To HedClmsCnt
Let arrOut(RwCnt + 1, ClmCnt) = Clms(ClmCnt - 1)
Next ClmCnt
Else
End If
Next RwCnt
Rem 2d) Put values from text file into first worksheet
Ws1.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
End Sub

DocAElstein

05-08-2020, 12:57 PM

Try number 12976436. Education in Text files

In support of this Thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=34629
DF.txt
Text file, DF.txt (https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic) https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Original uploaded DF.txt looked like this (https://imgur.com/PWq9xQC) as seen for example using a Text Editor (https://imgur.com/Fe3NFt8). ( Notepad is just one of many available text editors )
10,18052020,9.23,0015378
20,1018GS2026,GS,IN0020010081,0.00,0.00,10.00,0.00 ,0.00,10.00
20,1025GS2021,GS,IN0020010040,0.00,0.00 ……..etc.
You are using a comma in DF.txt (https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic) to separate the values. Because you are using a comma to separate your values , we sometimes call such a file a comma separated values file., and we often give a comma separated values text file the extension .csv. But you don’t have to. It’s is your choice. Both DF.txt or DF.csv is OK. You can use either for your text file.
You have used DF.txt for your comma separated values text file. That is a bit unusual, but it is OK. Its your choice.

This macro will allow us to examine that text file, ( for simplicity I am using a test file example of just 3 rows )
Sub WotsInDF_Text() ' ' http://www.eileenslounge.com/viewtopic.php?p=268809#p268809 What is in DF.txt : https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13273&viewfull=1#post13273
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\" & "DF_first 3 rows.txt" ' From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile) ' 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=11016&viewfull=1#post11016 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11818&viewfull=1#post11818

End Sub

here is the full single string of the text file, shown in two forms:
_ as seen in a text editor
_ in a VBA code line form

10,18052020,9.23,001537820,1018GS2026,GS,IN0020010 081,0.00,0.00,10.00,0.00,0.00,10.0020,1025GS2021,G S,IN0020010040,0.00,0.00,10.00,0.00,0.00,10.00
"10" & Chr(44) & "18052020" & Chr(44) & "9" & "." & "23" & Chr(44) & "0015378" & vbCr & vbLf & "20" & Chr(44) & "1018GS2026" & Chr(44) & "GS" & Chr(44) & "IN0020010081" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & vbCr & vbLf & "20" & Chr(44) & "1025GS2021" & Chr(44) & "GS" & Chr(44) & "IN0020010040" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00"

here the same again, just shown slightly differently for easy of explanation

"10" & Chr(44) & "18052020" & Chr(44) & "9" & "." & "23" & Chr(44) & "0015378" & vbCr & vbLf
& "20" & Chr(44) & "1018GS2026" & Chr(44) & "GS" & Chr(44) & "IN0020010081" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & vbCr & vbLf
& "20" & Chr(44) & "1025GS2021" & Chr(44) & "GS" & Chr(44) & "IN0020010040" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "0" & "." & "00" & Chr(44) & "10" & "." & "00"

we see the value seperator comma , ( character 44 ) and the line seperator, vbCr & vbLf

In support of this Thread: https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427
Alert 24 Mai..csv Alert 24 MaiDotDotcsv.jpg : https://imgur.com/0HsAOLj

We analyse using the same macro as above, with this changed code line

Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\" & "Alert 24 Mai..csv" ' https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files Share ‘Alert 24 Mai..csv’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

Here is the results

NSE,236,6,>,431555,A,,,,,GTTNSE,25,6,>,431555,A,,,,,GTTNSE,15083,6,>,431555,A,,,,,GTTNSE,17388,6,>,431555,A,,,,,GTTNSE,100,6,>,431555,A,,,,,GTTNSE,22,6,>,431555,A,,,,,GTT,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,, ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,Entire row of row 3 & row 4 both will be deleted after runing the macro,,,,,,

"NSE" & Chr(44) & "236" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "25" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "15083" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "17388" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "100" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "22" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vb
Lf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "Entire" & " " & "row" & " " & "of" & " " & "row" & " " & "3" & " " & "&" & " " & "row" & " " & "4" & " " & "both" & " " & "will" & " " & "be" & " " & "deleted" & " " & "
after" & " " & "runing" & " " & "the" & " " & "macro" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf

Here again adjusted for clarity

"NSE" & Chr(44) & "236" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "25" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "15083" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "17388" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "100" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
"NSE" & Chr(44) & "22" & Chr(44) & "6" & Chr(44) & Chr(62) & Chr(44) & "431555" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf &
Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "Entire" & " " & "row" & " " & "of" & " " & "row" & " " & "3" & " " & "&" & " " & "row" & " " & "4" & " " & "both" & " " & "will" & " " & "be" & " " & "deleted" & " " & "after" & " " & "runing" & " " & "the" & " " & "macro" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf

.csv text file is using commas , for the value separator, and for the line separate it has the typical convention of vbCr & vbLf

DocAElstein

05-08-2020, 12:57 PM

In Support of this forum question
https://eileenslounge.com/viewtopic.php?p=268481#p268481

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O
P
Q

6
#VALUE!Got missing number in column ECSE equivalentCSE equivalent

7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10

8eileenslounge
1000.00
1000Got one or more missing numbers

9
1eileenslounge1
4.00
4Got missing number in column E

10
1
2eileenslounge2
9.00
9

11
2
3Others
16.00
16

12
3
4eileenslounge
1000.00
1000

13
4
5eileenslounge1
36.00
36

14
5
6eileenslounge2
49.00
49

15
6
7Others
64.00
64

16
7
8

17
8
Worksheet: data

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O
P
Q

6
=IF(G6="eileenslounge",1000,F7*E8)=IF(F7="","Got one or more missing numbers",IF(E8="","Got missing number in column E",""))CSE equivalentCSE equivalent

7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10

8eileenslounge
=IF(G8="eileenslounge",1000,F9*E10)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))

9
1eileenslounge1
=IF(G9="eileenslounge",1000,F10*E11)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))

10
1
2eileenslounge2
=IF(G10="eileenslounge",1000,F11*E12)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))

11
2
3Others
=IF(G11="eileenslounge",1000,F12*E13)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))

12
3
4eileenslounge
=IF(G12="eileenslounge",1000,F13*E14)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))

13
4
5eileenslounge1
=IF(G13="eileenslounge",1000,F14*E15)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))

14
5
6eileenslounge2
=IF(G14="eileenslounge",1000,F15*E16)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))

15
6
7Others
=IF(G15="eileenslounge",1000,F16*E17)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(F8:F16="","Got one or more missing numbers",IF(E8:E15="","Got missing number in column E",""))

16
7
8

17
8
Worksheet: data

DocAElstein

05-13-2020, 12:58 PM

In Support of this forum question
https://eileenslounge.com/viewtopic.php?p=268481#p268481

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O

5CSE equivalentCSE equivalent

6
=IF(G6="eileenslounge",1000,F7*E8)=IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))

7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10

8eileenslounge
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))

9
1eileenslounge1
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))

10
1
2eileenslounge2
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))

11
2
3Others
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))

12
3
4eileenslounge
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))

13
4
5eileenslounge1
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))

14
5
6eileenslounge2
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))

15
6
7Others
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E17)=IF(E8:E16="","Got one or more missing numbers",IF(F8:F15="","Got missing number in column E",""))

16
7
8

17
8

18
Worksheet: data

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O

5CSE equivalentCSE equivalent

6
#VALUE!Got missing number in column F

7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10

8eileenslounge
1000Got one or more missing numbers

9
1eileenslounge1
4Got one or more missing numbers

10
1
2eileenslounge2
9

11
2
3Others
16

12
3
4eileenslounge
1000

13
4
5eileenslounge1
36

14
5
6eileenslounge2
49

15
6
7Others
64

16
7
8

17
8

18
Worksheet: data

DocAElstein

05-13-2020, 01:15 PM

Macro accomnpanying last post

Sub EvaluateRangeFormulasC() ' https://eileenslounge.com/viewtopic.php?p=268537#p268537
Dim Ws As Worksheet, Rng As Range, Clm As Range, lRow As Long
Const fRow As Long = 6: Const sRow As Long = 8
Set Ws = ThisWorkbook.Worksheets("data")
' Let lRow = Ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Let lRow = Ws.Range("G" & Ws.Rows.Count & "").End(xlUp).Row ' ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
On Error Resume Next
Set Rng = Ws.Rows(fRow).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Rng Is Nothing Then MsgBox "No formulas!": Exit Sub

Let Application.ScreenUpdating = False
For Each Clm In Rng
Dim strEval As String ' ' Formula in column H Formula in column J
Let strEval = Clm.Formula: Debug.Print strEval ' =IF(G6="eileenslounge",1000,F7*E8) =IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
' modifications to make first formula work in CSE / Range Evaluate sort of a way
Let strEval = Replace(strEval, "G6", "G8:G" & lRow & ""): Debug.Print strEval ' =IF(G8:G15="eileenslounge",1000,F7*E8) =IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
Let strEval = Replace(strEval, "F7*E8", "F9:F16*E10:E17" & lRow & ""): Debug.Print strEval ' =IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715) =IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
Debug.Print ' just to make an emty line in the Immediate window
' modifications required for second formula work in CSE / Range Evaluate sort of a way
Let strEval = Replace(strEval, "E7", "E8:E15" & lRow & ""): Debug.Print strEval ' =IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715) =IF(E8:E1515="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
Let strEval = Replace(strEval, "F8", "F8:F15" & lRow & ""): Debug.Print strEval ' =IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715) =IF(E8:E1515="","Got one or more missing numbers",IF(F8:F1515="","Got missing number in column F",""))
Let Clm.Offset(sRow - fRow).Resize(lRow - sRow + 1).Value = Evaluate(strEval)
Debug.Print ' just to make an emty line in the Immediate window
Next Clm

Let Application.ScreenUpdating = True
End Sub

Running the above macro on the test data in uploade file will give these results:

_____ Workbook: Converting formulas to valuesC.xlsm ( Using Excel 2007 32 bit )
Row\Col
E
F
G
H
I
J
K
L
M
N
O

5CSE equivalentCSE equivalent

6
#VALUE!Got missing number in column F

7
Title 5
Title 6
Title 7
Title 8
Title 9
Title 10

8eileenslounge
1000.00Got one or more missing numbers
1000Got one or more missing numbers

9
1eileenslounge1
4.00Got one or more missing numbers
4Got one or more missing numbers

10
1
2eileenslounge2
9.00
9

11
2
3Others
16.00
16

12
3
4eileenslounge
1000.00
1000

13
4
5eileenslounge1
36.00
36

14
5
6eileenslounge2
49.00
49

15
6
7Others
64.00
64

16
7
8

17
8

18
Worksheet: data

When in the VB Editor, after running the macro, you can hit keys Ctrl+g to see the following in the Immediate window. It shows the build up of the formulas in a full run

=IF(G6="eileenslounge",1000,F7*E8)
=IF(G8:G15="eileenslounge",1000,F7*E8)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715)

=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715)
=IF(G8:G15="eileenslounge",1000,F9:F16*E10:E1715)

=IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
=IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
=IF(E7="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))

=IF(E8:E1515="","Got one or more missing numbers",IF(F8="","Got missing number in column F",""))
=IF(E8:E1515="","Got one or more missing numbers",IF(F8:F1515="","Got missing number in column F",""))

DocAElstein

05-15-2020, 08:18 PM

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

.csv file before
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497
After downloading the
ALERT.xlsx
file at that post , I navigsted to it using Windows file explorer and physically changed it in the explorer window without opening it to
Alert29Apr..csv

Double clicking that gives this
_____ Workbook: Alert29Apr..csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1
22

2
25

3
15083

4
17388

5
Worksheet: ALERT

The string of thet file has 9096 Characters!! : https://pastebin.com/Ptk0f7S8
Share ‘9096Characters29Apr.xls’ : https://app.box.com/s/8g72lokzoil9fe6j645xcg8hej82gcn7

This is how it opens in Notepads
9096Characters29AprTextNotepads.JPG : https://imgur.com/USuCebF
2928
One of the few things I can see of any sense is towards the start is a "[Content_Types].xml" : -
"Content" & "_" & "Types" & Chr(93) & "." & "xml"
[Content_Types].xml

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

30 2

31 [91

32 C67

33 o111

34 n110

35 t116

36 e101

37 n110

38 t116

39 _95

40 T84

41 y121

42 p112

43 e101

44 s115

45 ]93

46 .46

47 x120

48 m109

49 l108

50 32

This sort of macro gets the long file string.

Sub WhatStringIsInAlertDotCSV() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=34497
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\At Eileen\" & "Alert29Apr..csv" ' This would be made if not existing and we would have a zero lenf string
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Dim Lenf As Long: Let Lenf = LOF(FileNum)
TotalFile = Space(Lenf) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile) ' ' 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
End Sub

There are no issues with the file format changing or in not getting the required format if this file is opened saved closed etc.. manually or using the below macro.
Further we see that we can change things, and even add worksheets, save and reopen... All changes and any added worksheets are still there!!
We are beginig to see the problem, or rather another twist in the confusion that is Avinash

Sub OpenEileensAlertDotCSV() ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13343&viewfull=1#post13343
Dim PathAndFileName As String
' The following file was uploaded as ALERT.xlsx I dowloaded it and I navigsted to it using Windows file explorer and physically changed it in the explorer window without opening it to Alert29Apr..csv
Let PathAndFileName = ThisWorkbook.Path & "\At Eileen\" & "Alert29Apr..csv"
Dim Wb As Workbook, WbSaveSimp As Workbook, WbSaveComp As Workbook ' Ws1 As Worksheet
Set Wb = Workbooks.Open(PathAndFileName)
Set WbSaveSimp = Wb: Set WbSaveComp = Wb
Wb.Close: Set Wb = Workbooks.Open(PathAndFileName)
Call WhatStringIsInAlertDotCSV
Wb.Save: Wb.Close
Call WhatStringIsInAlertDotCSV
' ' No issues so far

End Sub
We are beginig to see the problem, or rather another twist in the confusion that is Avinash. We do not always have a .csv file!!!!! - I can see this for example if I manually try to open the file that typically "works" for Avinash Trying to open Alert when it is not a csv.JPG : https://imgur.com/sS2vnw02927
( Note: This warning does not appear when opening the file by a macro, such as in the macro above! )
If I try to do a simple Save on such a file either manually or with coding as in the above macro , then ir is done OK. If I attempt a SaveAs then it will want to save it as an Excel File: Wants to SaveAs xlsx file.JPG : https://imgur.com/RAH3E9T 2929

Furthermore , there is not an issue if I SaveAs manually with a Filename of "Alert29Apr..csv" ,
Save Alert with doubledot csv as xlsx Excel File.JPG
But , it will end up as a new file "Alert29Apr..csv.xlsx
There are not issues with SaveAs saving it with coding: These will give us our Excel file masquerading as a .csv file
Wb.SaveAs Filename:=ThisWorkbook.Path & "\At Eileen" & "Alert29Apr..csv"
Wb.SaveAs Filename:=ThisWorkbook.Path & "\At Eileen" & "Alert29AprRemove a dot.csv"
There are no issues in reopening these files in coding, and also manually if the warning, ( about the file not being the type of the extension ) is ignored

DocAElstein

05-15-2020, 08:18 PM

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

Later

DocAElstein

05-15-2020, 08:18 PM

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

Later

DocAElstein

05-15-2020, 08:18 PM

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

VBA To Copy Rows From One Workbook To text csv File, Based On Count In A Different Workbook

Question
I have three files 2 Excel Files,1.xls & 3.xlsx , and a text file, 2.csv
1.xls first row has headers so don't count that
In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that many rows of 3.xlsx first row of sheet3 to 2.csv
suppose 1.xls has data in 5 rows then copy 3.xlsx first row of sheet3 and paste it to 2.csv 5 times
all files are located in a different path
sheet name can be anything

The final result should be a comma separated values text file , 2.csv.
For example, in Notepad, it looks like this:
2csv is a comma seperated text file.JPG : https://imgur.com/FEjKVMs
2935

That is the final result that I want

Answer:

Sub Step14() ' https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13367&viewfull=1#post13367 ' http://www.eileenslounge.com/viewtopic.php?f=30&t=34508 (zyxw123) https://excelfox.com/forum/showthread.php/2467-COPY-AND-PASTE?p=13182#post13182
Rem 1 Worksheets info
Dim w1 As Workbook, w2 As Workbook, w3 As Workbook
Set w1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' Workbooks("1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xlsx")
Set w2 = Workbooks.Open(ThisWorkbook.Path & "\2.csv") ' Workbooks("2.csv") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\document\2.csv")
Set w3 = Workbooks.Open(ThisWorkbook.Path & "\3.xlsx") ' Workbooks("3.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\files\3.xlsx")
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Set WS1 = w1.Worksheets.Item(1)
Set WS2 = w2.Worksheets.Item(1)
Set WS3 = w3.Worksheets.Item(1)
Dim Lc3 As Long, Lenf1 As Long, Lr1 As Long
Let Lr1 = WS1.Range("A" & WS1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Let Lc3 = WS3.Cells.Item(1, WS3.Columns.Count).End(xlToLeft).Column
Dim Lc3Ltr As String
Let Lc3Ltr = CL(Lc3)
Rem 2 ' In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv
Let Lenf1 = Lr1 - 1 ' 1.xls first row has headers so dont count that
' 2a)
Dim rngOut As Range: Set rngOut = WS2.Range("A1:" & Lc3Ltr & Lenf1 & "")
'' 2b)(i) Relative formula referrences ... https://teylyn.com/2017/03/21/dollarsigns/#comment-191
' WS2.Cells.NumberFormat = "General" ' May be needed to prevent formulas coming out as test =[3.xlsx]Sheet1!$A$1
' Let rngOut.Value = "='[3.xlsx]" & WS3.Name & "'!A$1"
' Let rngOut.Value = rngOut.Value ' Change Formulas to values
' Let rngOut.Value = Evaluate("If({1},SUBSTITUTE(" & rngOut.Address & ", ""0"", """"))") ' https://excelribbon.tips.net/T010741_Removing_Spaces
' Or
' 2b)(ii) Copy Paste
Dim rngIn As Range
Set rngIn = WS3.Range("A1:" & Lc3Ltr & "1")
rngIn.Copy
rngOut.PasteSpecial Paste:=xlPasteValues ' understanding Paste across ranges of different size to Copy range : https://excelfox.com/forum/showthread.php/2221-VBA-Range-Insert-Method-Code-line-makes-a-space-to-put-new-range-in?p=10441&viewfull=1#post10441

Rem 3
' 3a
w1.Close
w3.Close
' 3b
w2.SaveAs Filename:=ThisWorkbook.Path & "\2.csv", FileFormat:=xlCSV
Let Application.DisplayAlerts = False
w2.Close
Let Application.DisplayAlerts = True

End Sub

DocAElstein

05-15-2020, 08:18 PM

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

Later

My first answer here was almost perfect. https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13185&viewfull=1#post13185
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13184&viewfull=1#post13184

This was your question:
i have three files 1.xls & 2.csv & 3.xlsx
1.xls first row has headers so dont count that
In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that much time of 3.xlsx first row of sheet3 to 2.csv
suppose 1.xls has data in 5 rows then copy 3.xlsx first row of sheet3 and paste it to 2.csv 5 times
all files are located in a different path
sheet name can be anything

You question should have been you question:
VBA To Copy Rows From One Workbook To text csv File, Based On Count In A Different Workbook
I have three files 2 Excel Files,1.xls & 3.xlsx , and a text file, 2.csv
1.xls first row has headers so don’t count that
In 1.xls count the total number of rows that has data and copy the 3.xlsx sheet3 first row(first complete row copy) and paste that many rows of 3.xlsx first row of sheet3 to 2.csv
suppose 1.xls has data in 5 rows then copy 3.xlsx first row of sheet3 and paste it to 2.csv 5 times
all files are located in a different path
sheet name can be anything

The final result should be a comma separated values text file , 2.csv.
For example, in Notepad, it looks like this:
2csv is a comma seperated text file.JPG : https://imgur.com/FEjKVMs

That is the final result that I want

Here is the new solution from me : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13346&viewfull=1#post13346

Only a very small change was required:

' 3b
w2.SaveAs Filename:=ThisWorkbook.Path & "\2.csv", FileFormat:=xlCSV
Let Application.DisplayAlerts = True
w2.Close

Avinash
Read this, and try to understand at least a little of it.
2.csv is a test file. It is not an Excel file.
For example, in Notepad, it looks like this: [/color]
2csv is a comma seperated text file.JPG : https://imgur.com/FEjKVMs

2.csv is a test file. It is not an Excel file.
You can open a .csv file in Excel, and Excel will do its best to display the data in columns

Sometime Excel will do this:

_____ Workbook: 2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
6AGTT

2NSE
6AGTT

3NSE
6AGTT

4NSE
6AGTT

5NSE
6AGTT

6
Worksheet: 2

Sometimes Excel will do this:

_____ Workbook: 2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C

1NSE,,6,,,A,,,,,GTT

2NSE,,6,,,A,,,,,GTT

3NSE,,6,,,A,,,,,GTT

4NSE,,6,,,A,,,,,GTT

5NSE,,6,,,A,,,,,GTT

6
Worksheet: 2

DocAElstein

05-15-2020, 08:18 PM

https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

Alert..txt from Avinash : FromAvinashTextFileAlet__txt.JPG : https://imgur.com/HDHgB0z

USA,101010,6,<,12783,A,,,,,GTT,
USA,22,6,<,12783,A,,,,,GTT,
USA,17388,6,<,12783,A,,,,,GTT,
USA,100,6,<,12783,A,,,,,GTT,
USA,25,6,<,12783,A,,,,,GTT,

"USA" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf & "USA" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf & "USA" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf & "USA" & "," & "100" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf & "USA" & "," & "25" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," & vbLf

"USA" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf & "USA" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf & "USA" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf & "USA" & "," & "100" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf & "USA" & "," & "25" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & "," &
vbLf
You will see that vbLf is the separator for lines(records)

This is the macro i used to get that infomation:

Sub WhatStringIsInAlertDotDot_txt() ' 9th June 2020 https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\Alert..txt" ' This would be made if not existing and we would have a zero lenf string
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Dim Lenf As Long: Let Lenf = LOF(FileNum)
TotalFile = Space(Lenf) '....and wot recives it hs to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' What the fuck is in this string?
Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile) ' 'https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page34#post13699 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
End Sub

Here is the macro to answer this thread
https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file

' https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file
Sub xlsxTotxt_LineSeperatorvbLf_valuesSeperatorComma()
Rem 1 Workbooks info
Dim Wb1 As Workbook: Set Wb1 = Workbooks("sample2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb1.Worksheets.Item(1)
Dim Lr As Long, Lc As Long
Let Lr = Ws1.Cells.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Let Lc = Ws1.Cells.Item(1, Ws1.Columns.Count).End(xlToLeft).Column
Dim arrIn() As Variant: Let arrIn() = Ws1.Range(Ws1.Range("A1"), Ws1.Cells.Item(Lr, Lc)).Value ' Data range in sample2.xlsx
Rem 2 make text file long string
Dim Rw As Long, Clm As Long '
For Rw = 1 To Lr ' each row in Ws1
For Clm = 1 To Lc ' each column for each row in Ws1
Dim strTotalFile As String
Let strTotalFile = strTotalFile & arrIn(Rw, Clm) & "," ' add a value and a seperator for this line
Next Clm
Let strTotalFile = Left(strTotalFile, Len(strTotalFile) - 1) ' this will take off the last ,
Let strTotalFile = strTotalFile & vbLf ' this adds the line seperator wanted by Avinash - https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13348 - You will see that vbLf is the separator for lines(records)
Next Rw
Let strTotalFile = Left(strTotalFile, Len(strTotalFile) - 1) ' this takes off the last vbLf
Debug.Print strTotalFile
Rem 3 make text file from the total string
Dim FileNum As Long
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\csv Text file Chaos\Alert..txt" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, strTotalFile ' strTotalFile
Close #FileNum

End Sub

DocAElstein

05-15-2020, 08:18 PM

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13349 )

Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364

See here ( This post https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13349 )
for typical comparisons of text Files, Excel files, and data files
Text File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13693&viewfull=1#post13693
Excel File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13694&viewfull=1#post13694
Data File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13695&viewfull=1#post13695

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

Excel Files
A

B

C

D

E

F

G

H

I

J

K

1
USA
vbTab
101010
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT

vbCr
&
vbLf

2
USA
vbTab
22
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT

vbCr
&
vbLf

3
USA
vbTab
17388
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT

vbCr
&
vbLf

4
USA
vbTab
100
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT

vbCr
&
vbLf

5
USA
vbTab
25
vbTab
6
vbTab
<
vbTab
12783
vbTab
A
vbTab

vbTab

vbTab

vbTab

vbTab
GTT

vbCr
&
vbLf

Worksheet: Sheet1

DocAElstein

05-15-2020, 08:18 PM

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13693&viewfull=1#post13693 )

Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364

Text Files

USA
;
101010
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT

LineSeprator

USA
;
22
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT

LineSeprator

USA
;
17388
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT

LineSeprator

USA
;
100
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT

LineSeprator

USA
;
25
;
6
;
<
;
12783
;
A
;

;

;

;

;
GTT

LineSeprator

Note: With Text files we must concern ourselves with the Record/Line(row) separator and the Field(column) Separator: They may vary. We must know about these.

DocAElstein

05-15-2020, 08:18 PM

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13694&viewfull=1#post13694 )

Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364

In Excel we do not have to concern ourselves with the row separator used internally by Excel ( vbCr & vbLf ), or the column Separator used internally by Excel ( vbTab ) : Excel does this for us. We do not need to add these when working with Excel Files. Internally, Excel uses those separators to make the cells that we see and work with.

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

Excel FilesABCDEFGHIJK

1USAvbTab101010vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf

2USAvbTab22vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf

3USAvbTab17388vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf

4USAvbTab100vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf

5USAvbTab25vbTab6vbTab<vbTab12783vbTabAvbTabvbTabvbTabvbTabvbTabGTT

vbCr & vbLf
Worksheet: Sheet1

Note: In Excel we do not have to concern ourselves with the row seperator, vbCr & vbLf or the column Seperator, vbTab: Excel does this for us. We do not need to add these when working with Excel Files
We will only see this:

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

Excel FilesABCDEFGHIJKL

1USA1010106<12783AGTT

2USA226<12783AGTT

3USA173886<12783AGTT

4USA1006<12783AGTT

5USA256<12783AGTT

6
Worksheet: Sheet1

DocAElstein

05-15-2020, 08:18 PM

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13695&viewfull=1#post13695 )

Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364

Field1
Field2
Field3
Field4
Field5
Field6
Field7
Field8
Field9
Field10
Field11

Data Files
F1
F2
F3
F4
F5
F6
F7
F8
F9
F10
F11

Row1
Line1
Record1
USA
101010
6
<
12783
A

GTT

Row2
Line2
Record2
USA
22
6
<
12783
A

GTT

Row3
Line3
Record3
USA
17388
6
<
12783
A

GTT

Row4
Line4
Record4
USA
100
6
<
12783
A

GTT

Row5
Line5
Record5
USA
25
6
<
12783
A

GTT

Data files are held in computer memory in different forms and retrieved in different ways. Any particular value may be referrenced in many different ways.

DocAElstein

05-15-2020, 08:18 PM

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

Later

DocAElstein

05-15-2020, 08:18 PM

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

Later

DocAElstein

05-15-2020, 08:18 PM

Some notes related to these posts
https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706

Later

DocAElstein

05-18-2020, 01:19 PM

In support of this post:
https://excelfox.com/forum/showthread.php/2493-VBA-required-to-delimit-cells-with-Rules-applied-over-it

_____ Workbook: address sheet.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1AddressDoor#Directionstreet nameroadtypestreet name + roadtypeCity Name

2
204 6 AVE NW
204
6AVENW

3
2510 5 AVE N
2510
5AVEN

4
1 CICADA RD
1CICADARD

5
100 annacis Pkwy
100annacisPkwy

6
100 MAIN ST
100MAINST

7
10008 107 ST
10008
107ST

8
1001 110 AVE
1001
110AVE

9
10010 102A AVE NW
10010102A AVENW

10
10115 110 AVE
10115
110AVE

11
102 11 AVE S
102S
11AVE

12
10205 134 AVE NW
10205134 AVENW

13
10235 101 ST NW
10235101 STNW

14
10365 97 ST NW
1036597 STNW

15
105 MARTIN ST
105MARTINST

16
10504 100 AVE
10504
100AVE

17
10600 100 ST
10600
100ST
Worksheet: Sheet1

DocAElstein

05-18-2020, 03:30 PM

Some notes in support in answering this question: https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches

If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx and if it matches then copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to sheet 1 of 2.xlsx in the row of the matched value in column A of sheet 1 of 2.xlsx
i have pasted the result in sheet3 of 2.xlsx but the result should be in sheet1(I have pasted the result in sheet3 only for understanding purpose)

Before:

If column J has data in actual file.xlsx then match column B of actual file.xlsx
_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEASHOKLEYEQ
65
65.35
60.55
63.3
63.3
1

3NSEBANKBARODAEQ
62.1
62.95
56.15
56.65
56.65
1

4NSEBELEQ
66.15
66.75
62.4
65.65
65.65
1

5NSEEQUITASEQ
82
82.05
71
73.05
73.05
1

6NSEFEDERALBNKEQ
68
68.45
62.45
63.1
63.1
1

7NSEGAILEQ
85
88.8
79.1
79.95
79.95
1

8NSEIDFCFIRSTBEQ
32.1
32.35
27.2
27.55
27.55
Worksheet: Sheet1

_.................If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx
_____ Workbook: 2 18May.xlsx ( Using Excel 2007 32 bit )
Row\Col
A

1Stock Name

2ACC

3ADANIENT

4ADANIPORTS

5ASHOKLEY

6EQUITAS

7L&TFH

8
Worksheet: Sheet1

If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx and if it matches then copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to sheet 1 of 2.xlsx
_____ Workbook: 2 18May.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1
1
2
3
4
5
6
7
8
9
10
Worksheet: Sheet2

_.......copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to sheet 1 of 2.xlsx
i have pasted the result in sheet3 of 2.xlsx but the result should be in sheet1(I have pasted the result in sheet3 only for understanding purpose)

After:

_____ Workbook: 2 18May.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M

1Stock Namedatadatadatadatadatadatadatadatadatadatadatada ta

2ACC
100
108
120
128
134
151
6534
30
90
97
103

3ADANIENT
101
109
121
127
135
122
782
40
92
98

4ADANIPORTS
102
110
122
16
137
177
10
50
93
99
104

5ASHOKLEY
1
2
3
4
5
6
7
8
9
10

6EQUITAS
1
2
3
4
5
6
7
8
9
10

7AMBUJACEM
105
117
125
133
140
746
23
80
96
102
109

8
Worksheet: Sheet3

DocAElstein

05-18-2020, 06:20 PM

macro for solution to this Thread:
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches

( Remember to include Public Function CL() )

Sub CopyPaste20() ' https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches
Rem 1 Worksheets info
' 2.xlsx
Dim Wb2 As Workbook
Set Wb2 = Workbooks("2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' 2.xlsx sheet1 column A
Dim Ws2 As Worksheet: Set Ws2 = Wb2.Worksheets.Item(2)
Dim Rng22 As Range: Set Rng22 = Ws2.Range("A1").CurrentRegion ' Row to be copied - (only first row)entire row of data from sheet2 of 2.xlsx

' Actual File.xlsx
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Actual File.xlsx")
Set Ws = Wb.Worksheets.Item(1)
Dim Jmax As Long: Let Jmax = Ws.Range("J" & Ws.Rows.Count & "").End(xlUp).Row
Dim arrB() As Variant: Let arrB() = Ws.Range("B1:B" & Jmax & "").Value2 ' Actual File.xlsx sheet1 column B

Rem 2 do it
Dim Cnt ' this is for - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
For Cnt = 2 To Jmax
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrA(Cnt, 1), arrB(), 0) ' - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
If IsError(MtchRes) Then
' no match do nothing
Else ' Cnt is now at the row number of where 2.xlsx sheet1 column A was found in Actual File.xlsx sheet1 column B
Dim Lc1Cnt As Long: Let Lc1Cnt = Ws1.Cells.Item(Cnt, Ws1.Columns.Count).End(xlToLeft).Column
Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").ClearContents ' clear row Cnt of all data before pasting
Rng22.Copy Destination:=Ws1.Range("B" & Cnt & "") ' copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to the row in sheet 1 of 2.xlsx at the row number of the matched value of 2.xlsx sheet1
End If
Next Cnt
End Sub

' http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

DocAElstein

05-19-2020, 02:57 AM

Notes for question 2 here
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13379&viewfull=1#post13379
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13387&viewfull=1#post13387

Before is as here ,
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13382&viewfull=1#post13382
, but ignore Sheet2 - no row is to be copied

If column J has data in actual file.xlsx then match column B of actual file.xlsx

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEASHOKLEYEQ
65
65.35
60.55
63.3
63.3
1

3NSEBANKBARODAEQ
62.1
62.95
56.15
56.65
56.65
1

4NSEBELEQ
66.15
66.75
62.4
65.65
65.65
1

5NSEEQUITASEQ
82
82.05
71
73.05
73.05
1

6NSEFEDERALBNKEQ
68
68.45
62.45
63.1
63.1
1

7NSEGAILEQ
85
88.8
79.1
79.95
79.95
1

8NSEIDFCFIRSTBEQ
32.1
32.35
27.2
27.55
27.55

9NSEIOCEQ
93
93.65
87.25
87.9
87.9

10NSEL&TFHEQ
90
91.55
80.5
81.65
81.65

11
Worksheet: Sheet1 (2)

_.................If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx

_____ Workbook: 2 (2).xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1Stock Namedatadatadatadatadatadatadatadatadatadatadatada tadatadata

2ACC
100
108
120
128
134
151
6534
30
90
97
103

3ADANIENT
101
109
121
127
135
122
782
40
92
98

4ADANIPORTS
102
110
122
16
137
177
10
50
93
99
104

5ASHOKLEY
1
2
3
4
5
16
137
177
10
50
93
99
104

6EQUITAS
10
50
93
99
5
102
110
122
9
10
11

7L&TFH
11
12
13
14
15
16
17
18
19
20
21
22
23

8
Worksheet: Sheet1

If column J has data in actual file.xlsx then match column B of actual file.xlsx with column A of sheet 1 of 2.xlsx and if it matches then double the value of that row of 2.xlsx

After

_____ Workbook: 2 (2).xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1Stock Namedatadatadatadatadatadatadatadatadatadatadatada tadatadata

2ACC
100
108
120
128
134
151
6534
30
90
97
103

3ADANIENT
101
109
121
127
135
122
782
40
92
98

4ADANIPORTS
102
110
122
16
137
177
10
50
93
99
104

5ASHOKLEY
2
4
6
8
10
32
274
354
20
100
186
198
208

6EQUITAS
20
100
186
198
10
204
220
244
18
20
22

7L&TFH
22
24
26
28
30
32
34
36
38
40
42
44
46

8
Worksheet: Sheet2

Note: I think your supplied After is wrong! - L&TFH should not be considered from Actual File.xlsx, because J of that row is not 1

DocAElstein

05-19-2020, 03:26 AM

Macro for last post

Sub CopyPaste20Q2() ' Question 2 https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches
' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13388&viewfull=1#post13388
Rem 1 Worksheets info
' 2.xlsx
Dim Wb2 As Workbook
Set Wb2 = Workbooks("2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' 2.xlsx sheet1 column A
' Dim Ws2 As Worksheet: Set Ws2 = Wb2.Worksheets.Item(2)
' Dim Rng22 As Range: Set Rng22 = Ws2.Range("A1").CurrentRegion ' Row to be copied - (only first row)entire row of data from sheet2 of 2.xlsx

' Actual File.xlsx
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Actual File.xlsx")
Set Ws = Wb.Worksheets.Item(1)
Dim Jmax As Long: Let Jmax = Ws.Range("J" & Ws.Rows.Count & "").End(xlUp).Row
Dim arrB() As Variant: Let arrB() = Ws.Range("B1:B" & Jmax & "").Value2 ' Actual File.xlsx sheet1 column B

Rem 2 do it
Dim Cnt ' this is for - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
For Cnt = 2 To Jmax
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrA(Cnt, 1), arrB(), 0) ' - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
If IsError(MtchRes) Then
' no match do nothing
Else ' Cnt is now at the row number of where 2.xlsx sheet1 column A was found in Actual File.xlsx sheet1 column B
Dim Lc1Cnt As Long: Let Lc1Cnt = Ws1.Cells.Item(Cnt, Ws1.Columns.Count).End(xlToLeft).Column
' Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").ClearContents ' clear row Cnt of all data before pasting
' Rng22.Copy Destination:=Ws1.Range("B" & Cnt & "") ' copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to the row in sheet 1 of 2.xlsx at the row number of the matched value of 2.xlsx sheet1
Let Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Value = Ws1.Evaluate("=2*" & Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Address & "") ' then double the value of that row of 2.xlsx
End If
Next Cnt
End Sub

DocAElstein

05-19-2020, 03:08 PM

Macro for this post:
https://excelfox.com/forum/showthread.php/2495-Conditional-calculation-and-pasting-of-the-data?p=13397&viewfull=1#post13397

Sub ConditionalCalcPaste() ' https://excelfox.com/forum/showthread.php/2495-Conditional-calculation-and-pasting-of-the-data
Rem 1 Worksheets info
'1a) 2.xlsx
Dim Wb2 As Workbook
Set Wb2 = Workbooks("2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' 2.xlsx sheet1 column A
'Dim Ws2 As Worksheet: Set Ws2 = Wb2.Worksheets.Item(2)
'Dim Rng22 As Range: Set Rng22 = Ws2.Range("A1").CurrentRegion ' Row to be copied - (only first row)entire row of data from sheet2 of 2.xlsx

'1b) Actual File.xlsx
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Actual File.xlsx")
Set Ws = Wb.Worksheets.Item(1)
Dim Lr As Long: Let Lr = Ws.Range("A" & Ws.Rows.Count & "").End(xlUp).Row ' Dim Jmax As Long: Let Jmax = Ws.Range("J" & Ws.Rows.Count & "").End(xlUp).Row

Dim rngIn As Range: Set rngIn = Ws.Range("A1:S" & Lr & "")
Dim arrIn() As Variant, arrOut() As Variant: Let arrIn() = rngIn.Value2
Dim arrB() As Variant: Let arrB() = Ws.Range("B1:B" & Lr & "").Value2 ' Ws.Range("B1:B" & Jmax & "").Value2 ' Actual File.xlsx sheet1 column B

'1c ' calculate the total value of column Q of ActualFile.xlsx and if it is Greater than S10 of ActualFile.xlsx then
Dim SomeQ As Double: Let SomeQ = Ws.Evaluate("=SUM(Q2:Q" & Lr & ")") ' total value of column Q of ActualFile.xlsx
Let SomeQ = Application.WorksheetFunction.Round(SomeQ, 2)
Dim S10Val As Double: Let S10Val = arrIn(10, 19) ' S10 of ActualFile.xlsx
If SomeQ > S10Val Then ' total value of column Q of ActualFile.xlsx and if it is Greater than S10 of ActualFile.xlsx then do nothing
' do nothing
ElseIf SomeQ < S10Val Then ' if it is lower than S10 of ActualFile.xlsx then divide S10 of ActualFile.xlsx with the total value of Column Q of ActualFile.xlsx
Dim S10dQ As Double: Let S10dQ = S10Val / SomeQ ' Divide S10 of ActualFile.xlsx with the total value of Column Q of ActualFile.xlsx
Let S10dQ = Int(S10dQ) ' Application.WorksheetFunction.Round(S10dQ, 4)
Dim Cnt ' this is for - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
For Cnt = 2 To Lr1 ' Jmax
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrA(Cnt, 1), arrB(), 0) ' - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
If IsError(MtchRes) Then
' no match do nothing
Else ' Cnt is now at the row number of where 2.xlsx sheet1 column A was found in Actual File.xlsx sheet1 column B
Dim Lc1Cnt As Long: Let Lc1Cnt = Ws1.Cells.Item(Cnt, Ws1.Columns.Count).End(xlToLeft).Column
' Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").ClearContents ' clear row Cnt of all data before pasting
' Rng22.Copy Destination:=Ws1.Range("B" & Cnt & "") ' copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to the row in sheet 1 of 2.xlsx at the row number of the matched value of 2.xlsx sheet1
Let Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Value = Ws1.Evaluate("=" & S10dQ & "*" & Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Address & "") ' Ws1.Evaluate("=2*" & Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Address & "") ' then double the value of that row of 2.xlsx
End If
Next Cnt
Else
' Sum = S10
End If ' SumQ>S10
End Sub

Share 'Actual File.xlsx' : https://app.box.com/s/9dfaq1997whyyj0jq7ew30sixcmq9zpm
Share '2.xlsx' : https://app.box.com/s/ij24a4nmnnvi0h4qr13h49ro05aouatk
Share 'macro.xlsm' : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

DocAElstein

05-20-2020, 12:12 AM

Test ranges used to answer this post:
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13401&viewfull=1#post13401

Before:

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEASHOKLEYEQ
65
65.35
60.55
63.3
63.3
1
1
60
1.055
1.055
54
56.97

3NSEBANKBARODAEQ
62.1
62.95
56.15
56.65
56.65
1
6
60
0.944167
5.665
54
50.985

4NSEBELEQ
66.15
66.75
62.4
65.65
65.65
1
6
60
1.094167
6.565
54
59.085

5NSEEQUITASEQ
82
82.05
71
73.05
73.05
1
1
60
1.2175
1.2175
54
65.745

6NSEFEDERALBNKEQ
68
68.45
62.45
63.1
63.1
1
6
60
1.051667
6.31
54
56.79

7NSEGAILEQ
85
88.8
79.1
79.95
79.95
1
6
60
1.3325
7.995
54
71.955

8NSEIDFCFIRSTBEQ
32.1
32.35
27.2
27.55
27.55
1
60
0.459167
0.459167
54
24.795

9NSEIOCEQ
93
93.65
87.25
87.9
87.9
1
60
1.465
1.465
54
79.11

10NSEL&TFHEQ
90
91.55
80.5
81.65
81.65
6
51
1.60098
9.605882
54
86.45294

11
Worksheet: Sheet1 (2)

_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1Stock Namedatadatadatadatadatadatadatadatadatadatadatada tadatadata

2ACC
100
108
120
128
134
151
6534
30
90
97
103

3ADANIENT
101
109
121
127
135
122
782
40
92
98

4ADANIPORTS
102
110
122
16
137
177
10
50
93
99
104

5ASHOKLEY
1
2
3
4
5
16
137
177

6ANJALIPHARMA
10
50
93
99
5
102
110
122
9
10
11

7SUNTECK
11
12
13
14
15
16
17
18
19
20
21
22
23

8
Worksheet: Sheet1 (5)

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
O
P
Q
R
S

6
6.31
54
56.79

7
7.995
54
71.955 Total Fund Amount
8387.320769

8
0.459167
54
24.795Current Fund Amount
9000

9
1.465
54
79.11Fund Allocated
8000

10
9.605882
54
86.45294Profit Amount
1000

11Sum is
551.8879
Worksheet: Sheet1 (2)

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
Q

2
56.97

3
50.985

4
59.085

5
65.745

6
56.79

7
71.955

8
24.795

9
79.11

10
86.45294

11
=SUM(Q2:Q10)
Worksheet: Sheet1 (2)

In this example sum of column Q is less than Range S10 value so nothing is done

DocAElstein

05-20-2020, 12:24 AM

Macro for last post, and to answer this post:
https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13401&viewfull=1#post13401

Sub CopyPaste20Q2b() ' https://excelfox.com/forum/showthread.php/2494-Copy-and-paste-of-data-if-matches?p=13401&viewfull=1#post13401
Rem 1 Worksheets info
' 2.xlsx
Dim Wb2 As Workbook
Set Wb2 = Workbooks("2.xlsx")
Dim Ws1 As Worksheet: Set Ws1 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2 ' 2.xlsx sheet1 column A
'Dim Ws2 As Worksheet: Set Ws2 = Wb2.Worksheets.Item(2)
'Dim Rng22 As Range: Set Rng22 = Ws2.Range("A1").CurrentRegion ' Row to be copied - (only first row)entire row of data from sheet2 of 2.xlsx

' Actual File.xlsx
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Actual File.xlsx")
Set Ws = Wb.Worksheets.Item(1)
Dim Jmax As Long: Let Jmax = Ws.Range("J" & Ws.Rows.Count & "").End(xlUp).Row
Dim arrB() As Variant: Let arrB() = Ws.Range("B1:B" & Jmax & "").Value2 ' Actual File.xlsx sheet1 column B
'1c ' calculate the total value of column Q of ActualFile.xlsx and if it is Greater than S10 of ActualFile.xlsx then
Dim Lr As Long: Let Lr = Ws.Range("A" & Ws.Rows.Count & "").End(xlUp).Row
Dim SomeQ As Double: Let SomeQ = Ws.Evaluate("=SUM(Q2:Q" & Lr & ")") ' total value of column Q of ActualFile.xlsx
Let SomeQ = Application.WorksheetFunction.Round(SomeQ, 2)
Dim S10Val As Double: Let S10Val = Ws.Range("S10").Value ' S10 of ActualFile.xlsx
If SomeQ > S10Val Then ' total value of column Q of ActualFile.xlsx and if it is Greater than S10 of ActualFile.xlsx then this macro should do the process
Rem 2 do it
Dim Cnt ' this is for - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B but only as far as JMax
For Cnt = 2 To Lr1 ' Jmax
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrA(Cnt, 1), arrB(), 0) ' - going down column A of 2.xlsx sheet1 looking for a match in Actual File.xlsx sheet1 column B
If IsError(MtchRes) Then
' no match do nothing
Else ' Cnt is now at the row number of where 2.xlsx sheet1 column A was found in Actual File.xlsx sheet1 column B
Dim Lc1Cnt As Long: Let Lc1Cnt = Ws1.Cells.Item(Cnt, Ws1.Columns.Count).End(xlToLeft).Column
' Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").ClearContents ' clear row Cnt of all data before pasting
' Rng22.Copy Destination:=Ws1.Range("B" & Cnt & "") ' copy the (only first row)entire row of data from sheet2 of 2.xlsx and paste it to the row in sheet 1 of 2.xlsx at the row number of the matched value of 2.xlsx sheet1
Let Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Value = Ws1.Evaluate("=2*" & Ws1.Range("B" & Cnt & ":" & CL(Lc1Cnt) & Cnt & "").Address & "") ' then double the value of that row of 2.xlsx
End If
Next Cnt
Else
' else do nothing
End If
End Sub

DocAElstein

05-20-2020, 02:23 AM

Just testing
ignore all this

C:\Users

ror Resume Next
Set WB1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
If Err <> 0 Then

DocAElstein

05-24-2020, 12:58 PM

Macro for this Thread post
https://excelfox.com/forum/showthread.php/2499-calculation-by-percentage-and-conditionally-puting-the-data?p=13423&viewfull=1#post13423

Calculate 2% of colum H & column I & considered the greater number between them
column S should be positive, so don’t considere the no. which are negative
& if column S is lower than that 2% of column H or Column I (whichever is greater )then put -1
vba macro will be placed in a seperate file , sheet name can be anything, all files are located in different place
example
the U2 cell will become -1 after runing the macro

Sub CalculationByPercentageAndConditionallyPutingTheDa ta() ' https://excelfox.com/forum/showthread.php/2499-calculation-by-percentage-and-conditionally-puting-the-data?p=13423&viewfull=1#post13423
Rem worksheets info
' ap.xls
Dim Wbap As Workbook
Set Wbap = Workbooks("ap.xls")
Dim Wsap As Worksheet
Set Wsap = Wbap.Worksheets.Item(1)
Dim Lrap As Long: Let Lrap = Wsap.Range("B" & Wsap.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim Arrap As Variant: Let Arrap = Wsap.Range("A1:Y" & Lrap & "").Value2
' 1b) Evaluate range H and I at 2% - Calculate 2% of colum H & column I
Dim arrH2pc() As Variant, arrI2pc() As Variant
Let arrH2pc() = Evaluate("=2/100*H2:H" & Lrap & "")
Let arrI2pc() = Evaluate("=2/100*I2:I" & Lrap & "")

Rem 2
Dim arrS() As Variant: Let arrS() = Wsap.Range("S1:S" & Lrap & "").Value2
Dim arrU() As Variant: Let arrU() = Wsap.Range("U1:U" & Lrap & "").Value2
Dim Cnt As Long
For Cnt = 2 To Lrap
If arrS(Cnt, 1) >= 0 Then
Dim BgstHI As Double ' colum H & column I & considered the greater number between them
Let BgstHI = arrH2pc(Cnt - 1, 1) ' Cnt - 1 is because our arrays for the H and I columns start at row 2 , so the indices will be one less than the roe to which they apply . I chose to do this to avoid trying to get 2% of the header , as that would error
If arrH2pc(Cnt - 1, 1) < arrI2pc(Cnt - 1, 1) Then Let BgstHI = arrI2pc(Cnt - 1, 1) ' If I column is largest, use that, otherwise H will be taken NOTE: H will be taken if the H and I columnns are equal
If arrS(Cnt, 1) < BgstHI Then Let arrU(Cnt, 1) = -1
Else ' S < 0
' column S should be positive, so don’t considere the no. which are negative
End If
Next Cnt

Rem 3 paste out
Let Wsap.Range("U1:U" & Lrap & "").Value2 = arrU()
End Sub

arrHISU.JPG : https://imgur.com/uunxENf
2954

Share ‘macro.xlsm’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt
Share ‘ap.xls’ : https://app.box.com/s/pq6nqkfilk2xs5lf19ozcpx081rp47vs

DocAElstein

05-24-2020, 11:14 PM

macro for this post http://www.eileenslounge.com/viewtopic.php?p=268809#p268809

' From vixer zyxw1234 Avinash : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic Excel File, https://app.box.com/s/yyzt8ywwpkkn8vxtxumalp7eg3888jnu Sample1.xlsx
Sub TextFileToExcel() ' http://www.eileenslounge.com/viewtopic.php?p=268809#p268809
Rem 1 Workbooks, Worksheets info
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("Sample1.xlsx") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1) ' first worksheet
Dim lr As Long: Let lr = Ws.Range("A" & Ws.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim NxtRw As Long
If lr = 1 And Ws.Range("A1").Value = "" Then
Let NxtRw = 1 ' If there is no data in the worksheet we want the first row to be the start row
Else
Let NxtRw = lr + 1 ' If there is data in the worksheet, we ant the data to be posted after the last used row
End If
Rem 2 Text file info
' 2a) get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\" & "DF.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' we can now make an array for all the rows, and we know our columns are A-J = 10 columns
Dim arrOut() As String: ReDim arrOut(1 To RwCnt, 1 To 10)

Rem 3 An array is built up by _....
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To UBound(arrClms()) + 1
Let arrOut(Cnt, Clm) = arrClms(Clm - 1)
Next Clm
Next Cnt

Rem 4 Finally the array is pasted to the worksheet at the next free row
Let Ws.Range("A" & NxtRw & "").Resize(RwCnt, 10).Value = arrOut()
End Sub

Share ‘sample1.xlsx’ : https://app.box.com/s/r0tc0hkwoxrqjsqfu4gh7eqyy5jmqlg2
Share ‘macro.xlsm’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

DocAElstein

05-25-2020, 02:44 PM

In support of this Thread https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427

If column H of 1.xls is greater than column D of 1.xls then calculate 1% of column D of 1.xls & add it to column D of 1.xls and compare column D of 1.xls with column I of 1.xls & if column D of 1.xls is greater than column I of 1.xls then see column I and match column I of of 1.xls with column B of Alert..csv & if it matches then delete that entire row of Alert..csv
If column H of 1.xls is lower than column D of 1.xls then calculate 1% of column D of 1.xls & subtract it to column D of 1.xls and compare column D of 1.xls with column I of 1.xls & if column D of 1.xls is lower than column I then see column I of 1.xls and match column I of of 1.xls with column B of Alert..csv & if it matches then delete that entire row of Alert..csv

Excel File:
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEACCEQ
1172
1240
1161.6
1227.1
1227.1
22

3NSEADANIENTEQ
138
141.2
136.6
138.1
140
25

4NSEADANIPORTSEQ
315
315
306.55
310.6
312
15083

5NSEADANIPOWEREQ
33.5
34.5
32.85
33
33.2
17388

6NSEAMARAJABATEQ
600
613.5
586.9
592.55
592.55
100

7NSEASIANPAINTEQ
1568.8
1625
1555.4
1617.9
1617.9
236
Worksheet: 1-Sheet1 24Mai

Text File:

NSE,236,6,>,431555,A,,,,,GTT
NSE,25,6,>,431555,A,,,,,GTT
NSE,15083,6,>,431555,A,,,,,GTT
NSE,17388,6,>,431555,A,,,,,GTT
NSE,100,6,>,431555,A,,,,,GTT
NSE,22,6,>,431555,A,,,,,GTT
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,Entire row of row 3 & row 4 both will be deleted after runing the macro,,,,,

Row in 1.xls

2Column H is > column D Column D + 1% is > Column I 22 is matched to last line of data in Text File. So last line in data File should be removed.

3Column H is > column D Column D + 1% is > Column I 25 is matched to second line of data in Text File. So thisline in data File should be removed.

4Column H is < Column D Column D - 1% is < Column I 15083 is matched to third line of Text File. So this line is to be deleted

5Column H is < Column D Column D - 1% is < Column I 17388 is matched to forth line of Text File. So this line is to be deleted

6Column H is < Column D Column D - 1% is not < Column I so no match to be done , nothing more to be done

7Column H is > column D Column D + 1% is > Column I 236 is matched to first line of data in Text File. So first line in data File should be removed.

Text File after

NSE,100,6,>,431555,A,,,,,GTT
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,,,,,,
,,,,,Entire row of row 3 & row 4 both will be deleted after runing the macro,,,,,

DocAElstein

05-25-2020, 03:05 PM

Macro solution for this post: https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427

' https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427

Sub VBARemoveTextFileLineBasedOnExcelFileConditions()
Rem 1 Workbook, Worksheet info ( Excel File )
Dim Wb As Workbook, Ws As Worksheet
Set Wb = Workbooks("1.xls") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1)
Dim arrWs() As Variant: Let arrWs() = Ws.Range("A1").CurrentRegion.Value2
Dim Lr As Long: Let Lr = UBound(arrWs(), 1)
Rem 2 text File Info, Import into Excel
' 2a) get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & "\csv Text file Chaos\" & "Alert 24 Mai..csv" ' CHANGE TO SUIT From vixer : https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13427#post13427 Share ‘Alert 24 Mai..csv’ https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' Alert 24 MaiDotDotcsvBefore.JPG : https://imgur.com/jSZV7Bt , https://imgur.com/ckS9Rzq
' 2c) ' we can now make an array for all the rows, and we know our columns are A-K = 11 columns
Dim arrIn() As String: ReDim arrIn(1 To RwCnt, 1 To 11)
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To UBound(arrClms()) + 1
Let arrIn(Cnt, Clm) = arrClms(Clm - 1)
Next Clm
Next Cnt
' arrIn.jpg : https://imgur.com/agGbjHv
' 2d) second column in text file
Dim Clm2() As Variant: Let Clm2() = Application.Index(arrIn(), 0, 2) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Clm2.jpg : https://imgur.com/Z6jYp3V

Rem 3 Do it
Dim IndDel As String: Let IndDel = " " ' for indices to be deleted from rows out array ''_- an extra " " at the beginning : A spacee before means I will always get a corrent check of a number in the string
For Cnt = 2 To Lr ' considering each data row in 1.xls
Dim D1pc As Double ' for calculate 1% of column D of 1.xls
Dim MtchRes As Variant ' for match column I of of 1.xls with second data column of text file Alert..csv Clm2()
If arrWs(Cnt, 8) > arrWs(Cnt, 4) Then ' If column H of 1.xls is greater than column D of 1.xls then
Let D1pc = 1 / 100 * arrWs(Cnt, 4) ' calculate 1% of column D of 1.xls .._
Let arrWs(Cnt, 4) = arrWs(Cnt, 4) + D1pc ' _.. & add it to column D of 1.xls
If arrWs(Cnt, 4) > arrWs(Cnt, 9) Then ' If column D of 1.xls is greater than column I of 1.xls
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
If IsError(MtchRes) Then
' no match do nothing
Else
Let IndDel = IndDel & MtchRes - 1 & " " ' add an indicee of a row to be deleted
End If
Else
' column D of 1.xls is not greater than column I of 1.xls
End If

ElseIf arrWs(Cnt, 8) < arrWs(Cnt, 4) Then ' If column H of 1.xls is lower than column D of 1.xls then
Let D1pc = 1 / 100 * arrWs(Cnt, 4) ' calculate 1% of column D of 1.xls .._
Let arrWs(Cnt, 4) = arrWs(Cnt, 4) - D1pc ' & _.. subtract it to column D of 1.xls
If arrWs(Cnt, 4) < arrWs(Cnt, 9) Then ' If column D of 1.xls is lower than column I of 1.xls
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
If IsError(MtchRes) Then
' no match do nothing
Else
Let IndDel = IndDel & MtchRes - 1 & " " ' add an indicee of a row to be deleted
End If
Else
' column D of 1.xls is not lower than column I of 1.xls
End If
Else
' column H of 1.xls is = column D of 1.xls
End If ' end of column H compare to column D
Next Cnt

Rem 4 remake the text file row array
Dim arrRwsOut() As String ' array for making a new text file
Dim RwsOut As Long ' for row count in modified outpur rows array, arrrwsOut()
Dim RwDelCnt As Long: Let RwDelCnt = (Len(IndDel) - Len(Replace(IndDel, " ", "", 1, -1, vbBinaryCompare))) - 1 ' -1 because of an extra " " at the beginning - ''_- an extra " " at the beginning : A spacee before means I will always get a corrent check of a number in the string
ReDim arrRwsOut(0 To UBound(arrRws()) - RwDelCnt)
For Cnt = 0 To UBound(arrRws())
If InStr(1, IndDel, " " & Cnt & " ", vbBinaryCompare) = 0 Then
Let arrRwsOut(RwsOut) = arrRws(Cnt)
Let RwsOut = RwsOut + 1
Else
' do nothing since we are at a row to be deleted
End If
Next Cnt

Rem 5 remake the text file
'5a) make a new text file string
Dim strTotalFile As String
Let strTotalFile = Join(arrRwsOut(), vbCr & vbLf)
'5b) make new file
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\csv Text file Chaos\" & "Alert 24 Mai Out..csv" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, strTotalFile
Close #FileNum

End Sub

Text File given:
Share ‘Alert 24 Mai..csv’ : https://app.box.com/s/599q2it3uck3hfwm5kscmmgtn0be66wt

New text file made after running macro:
Share ‘Alert 24 Mai Out..csv’ : https://app.box.com/s/yseazrdyfloij4ktrhy4ejdpzl0cx02e

Share ‘1.xls’ : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk

Share ‘macro.xlsm’ : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p

DocAElstein

05-26-2020, 02:16 PM

test asdsdklj

aslkhSLHDSlhdslhfslkhasklh

ASFJALSKJFASLKJFASLKJFASLKFJALKSJFSLKAJ

lSHFLSHFHSLHF

DocAElstein

05-26-2020, 02:16 PM

assfhshffhsfskfh

DocAElstein

05-26-2020, 02:16 PM

In support of answer for this post.
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470#post13470

Text file supplied Sample2.csv ( Avinash : https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470
sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t )

NSE,101010,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
NSE,22,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
NSE,17388,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
,100,,,,,,,,,,,,,,,,,,,,,,
,25,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,Only for understanding purpose,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,Before runing the macro,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,After runing the macro,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,,,,,,,,,,,
,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT
,,,,,,,,,,,,,,100,,,,,,,,,
,,,,,,,,,,,,,,25,,,,,,,,,

Open in/ with Excel: ( Like: this: https://imgur.com/7pAaLVx , https://excelfox.com/forum/showthread.php/2500-Conditionally-delete-entire-row-with-calculation-within-files?p=13440&viewfull=1#post13440 , for example with text editor
OpenSample2_csvManually with Excel.JPG : https://imgur.com/e7CxxpV)
2963

_____ Workbook: sample2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B

1NSE,101010,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,

2NSE,22,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,

3NSE,17388,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,

4,100,,,,,,,,,,,,,,,,,,,,,,

5,25,,,,,,,,,,,,,,,,,,,,,,

6,,,,,,,,,,,,,,,,,,,,,,,

7,,,,,,,,,,,,,,,,,,,,,,,

8,,,,,,,,,,,,,,,,,,,,,,,

9,,,,,,,,,,,,,,,,,,,,,,,

10,,,,,,,,,,,,,,,,,,,,,,,

11,,,,,,,,,,,,,,,,,,,,,,,

12,,,,,,,,,,,,,,,,,,,,,,,

13,,,,,,,,,,,,,,,,,,,,,,,

14,,,,,,,,,,,,,,,,,,,,,,,

15,,,,,,,,,,,,,,,,,,,,,,,

16,,,,,,,,,,,,,Only for understanding purpose,,,,,,,,,,

17,,,,,,,,,,,,,,,,,,,,,,,

18,,,,,,,,,,,,,Before runing the macro,,,,,,,,,,

19,,,,,,,,,,,,,,,,,,,,,,,

20,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT

21,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT

22,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT

23,,,,,,,,,,,,,,,,,,,,,,,

24,,,,,,,,,,,,,,,,,,,,,,,

25,,,,,,,,,,,,,,,,,,,,,,,

26,,,,,,,,,,,,,,,,,,,,,,,

27,,,,,,,,,,,,,After runing the macro,,,,,,,,,,

28,,,,,,,,,,,,,,,,,,,,,,,

29,,,,,,,,,,,,,,,,,,,,,,,

30,,,,,,,,,,,,,,,,,,,,,,,

31,,,,,,,,,,,,,NSE,101010,6,<,12783,A,,,,,GTT

32,,,,,,,,,,,,,NSE,22,6,<,12783,A,,,,,GTT

33,,,,,,,,,,,,,NSE,17388,6,<,12783,A,,,,,GTT

34,,,,,,,,,,,,,,100,,,,,,,,,

35,,,,,,,,,,,,,,25,,,,,,,,,

36
Worksheet: sample2

Open with Excel VBA:

Sub OpenVBASample2_csv_5June() ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13476&viewfull=1#post13476
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' CHANGE TO SUIT
End Sub
' see next post : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13476&viewfull=1#post13476
see next post : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13476&viewfull=1#post13476

DocAElstein

05-26-2020, 02:16 PM

Sub OpenVBASample2_csv_5June() '
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' CHANGE TO SUIT
End Sub
_____ Workbook: sample2.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S
T
U
V
W
X

1NSE
101010
6<
12783AGTT

2NSE
22
6<
12783AGTT

3NSE
17388
6<
12783AGTT

4
100

5
25

6

7

8

9

10

11

12

13

14

15

16Only for understanding purpose

17

18Before runing the macro

19

20NSE
101010
6<
12783AGTT

21NSE
22
6<
12783AGTT

22NSE
17388
6<
12783AGTT

23

24

25

26

27After runing the macro

28

29

30

31NSE
101010
6<
12783AGTT

32NSE
22
6<
12783AGTT

33NSE
17388
6<
12783AGTT

34
100

35
25
Worksheet: sample2

Note : Sometimes Excel manually or Excel VBA will open .csv file and put values across column cells. but also sometimes Excel manually or Excel VBA will open .csv file and put all values and commas in first cell

DocAElstein

05-26-2020, 02:16 PM

Sample2After.csv

NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT
,100,,,,,,,,,,
,25,,,,,,,,,,

In Excel ( open manually )
Open Sample2_csv Manually with Excel.JPG : https://imgur.com/9QNhxrA
_____ Workbook: Sample2After.csv ( Using Excel 2007 32 bit )
Row\Col
A
B

1NSE,101010,6,<,12783,A,,,,,GTT

2NSE,22,6,<,12783,A,,,,,GTT

3NSE,17388,6,<,12783,A,,,,,GTT

4,100,,,,,,,,,,

5,25,,,,,,,,,,

6
Worksheet: Sample2After

In Excel VBA

_ Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT

_____ Workbook: Sample2After.csv ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L

1NSE
101010
6<
12783AGTT

2NSE
22
6<
12783AGTT

3NSE
17388
6<
12783AGTT

4
100

5
25

6
Worksheet: Sample2After

Note : Sometimes Excel manually or Excel VBA will open .csv file and put values across column cells. but also sometimes Excel manually or Excel VBA will open .csv file and put all values and commas in first cell

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToR wCnt)

"NSE" & Chr(44) & "101010" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "22" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & "NSE" & Chr(44) & "17388" & Chr(44) & "6" & Chr(44) & Chr(60) & Chr(44) & "12783" & Chr(44) & "A" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & "GTT" & vbCr & vbLf & Chr(44) & "100" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf & Chr(44) & "25" & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & Chr(44) & vbCr & vbLf

DocAElstein

05-26-2020, 02:16 PM

Macro for this post:
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470

' https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470#post13470
Sub VBAAppendDataToTextFileLineBasedOnTheTextFileAndEx celFileConditions()
Rem 1 Workbook, Worksheet info ( Excel File )
Dim Wb As Workbook, Ws As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb = Workbooks("1.xls") ' Workbooks("Sample1.xls") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1)
Dim arrWs() As Variant: Let arrWs() = Ws.Range("A1").CurrentRegion.Value2
Dim Lr As Long: Let Lr = UBound(arrWs(), 1)
Rem 2 text File Info, Import into Excel Array
Dim PathAndFileName As String, TotalFile As String
' Let PathAndFileName = ThisWorkbook.Path & "\" & "Alert 24 Mai..csv" '
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "Sample2.csv" ' "sample2 ef 5 June.csv" ' CHANGE TO SUIT From Avinash : https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470 sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
' 2a)(i) Determine rows (records) wanted, based on ... First column(field) not being empty
Dim RwCnt As Long, TextFileLineIn As String
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Input As #FileNum 'Open Route to data
Line Input #FileNum, TextFileLineIn ' First line
Do While Left(TextFileLineIn, 4) = "NSE," ' For text file lines like NSE,101010,6,<,12783,A,,,,,GTT
Let RwCnt = RwCnt + 1
Line Input #FileNum, TextFileLineIn ' next line in text file
Loop
Close #FileNum
' 2a)(ii) get the text file as a long single string
Let FileNum = FreeFile(1)
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
'Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' Alert 24 MaiDotDotcsvBefore.JPG : https://imgur.com/jSZV7Bt , https://imgur.com/ckS9Rzq
' 2c) ' we can now make an array for all the rows, and we know our columns are A-K = 11 columns
Dim arrIn() As String: ReDim arrIn(1 To RwCnt, 1 To 11)
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data but only those up to Rwcnt
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To 11
'For Clm = 1 To UBound(arrClms()) + 1
Let arrIn(Cnt, Clm) = arrClms(Clm - 1)
Dim TruncRw As String '_-
Let TruncRw = TruncRw & arrIn(Cnt, Clm) & "," '_- The idea of this is a bodge to get rid of a lot of extra ,,,,,,, if we have empty cells being used, as in Avinash original - sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t - https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13475&viewfull=1#post13475
Next Clm
Let arrRws(Cnt - 1) = Left(TruncRw, Len(TruncRw) - 1) '_- take off the last ,
Let TruncRw = ""
Next Cnt
' 2d) Re make text string of just rows to RwCnt
ReDim Preserve arrRws(0 To RwCnt - 1)
Dim TotalFileToRwCnt As String
Let TotalFileToRwCnt = Join(arrRws(), vbCr & vbLf) & vbCr & vbLf ' This is effectively our long string text file and an extra final carriage return and line feed
' 2d) second column in text file, up to RwCnt
Dim Clm2() As Variant: Let Clm2() = Application.Index(arrIn(), 0, 2) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Clm2Sample2csv.JPG : https://imgur.com/DYYAl3z

Rem 3 Do it
For Cnt = 2 To Lr ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs(Cnt, 11) > arrWs(Cnt, 4) And arrWs(Cnt, 8) > arrWs(Cnt, 11)) Or (arrWs(Cnt, 11) < arrWs(Cnt, 4) And arrWs(Cnt, 8) < arrWs(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of text file Sample2.csv Clm2()
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
' Match Column I of sample1.xls with second field values (column B) of sample2.csv
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to append second field values (column B) of sample2.csv
Let TotalFileToRwCnt = TotalFileToRwCnt & "," & arrWs(Cnt, 9) & ",,,,,,,,,," & vbCr & vbLf ' make the single text string for the output text file
End If

Else
' Neither of the 2 conditions are met so do nothing
End If

Next Cnt

Rem 5 remake the text file
''5a) make a new text file string
'Dim strTotalFile As String
' Let strTotalFile = Join(arrRwsOut(), vbCr & vbLf)
'5b) make new file
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\" & "Sample2After.csv" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, TotalFileToRwCnt ' strTotalFile
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToR wCnt)

'Rem 6 Check File in Excel VBA open
'' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
' Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT
'

End Sub

sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
Sample2After.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo

DocAElstein

05-26-2020, 02:16 PM

Macro for this post
https://excelfox.com/forum/showthread.php/2517-Copy-and-paste-the-data-if-condition-met

Sub VBAAppendDataToExcelFileRowBasedOnTwoExcelFileCond itions2() ' https://excelfox.com/forum/showthread.php/2517-Copy-and-paste-the-data-if-condition-met Previous macro where second file is .csv text file https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13616&viewfull=1#post13616
Rem 1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("Sample1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
Rem 2 sample2.xlsx
Dim Wb2 As Workbook, Ws2 As Worksheet
Set Wb2 = Workbooks("Sample2.xlsx")
Set Ws2 = Wb2.Worksheets.Item(1)
Dim RwCnt2 As Long: Let RwCnt2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
Dim NxtRw As Long: Let NxtRw = RwCnt2 + 1 ' next free row in sample2.xlsx
' 2d) second column in sample2.xlsx up maximum size of sample1.xls - that will be the biggest size needed
Dim Clm2() As Variant: Let Clm2() = Ws2.Range("B1:B" & Lr1 & "").Value ' Clm2Sample2xlsx.JPG

Rem 3 Do it
Dim Cnt As Long
For Cnt = 2 To Lr1 ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs1(Cnt, 11) > arrWs1(Cnt, 4) And arrWs1(Cnt, 8) > arrWs1(Cnt, 11)) Or (arrWs1(Cnt, 11) < arrWs1(Cnt, 4) And arrWs1(Cnt, 8) < arrWs1(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of Sample2.xls Clm2()
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I of of 1.xls with second column data of sample2.xlsx
' Match Column I of sample1.xls with second column (column B) of sample2.xlsx
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to second column values (column B) of sample2.xlsx
Let Clm2(NxtRw, 1) = arrWs1(Cnt, 9)
If NxtRw <> Lr1 Then Let NxtRw = NxtRw + 1 ' If we are not already at the maximum possible row in column B, Ws2 , then we need to adjust NxtRw for next possible missing match
End If

Else
' Neither of the 2 conditions are met so do nothing
End If

Next Cnt

Rem Paste out adjusted/ added to Ws2 column B
Ws2.Range("B1:B" & Lr1 & "").Value = Clm2()
End Sub

sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
sample2.xlsx : https://app.box.com/s/np7kbvjydnyiu95pzyrgn76qi1uqg0ma
vba.xlsm : https://app.box.com/s/lf6otsrl42m6vxxvycjo04zidya6pd2m

DocAElstein

05-26-2020, 02:16 PM

Macro to answer this Thread
https://excelfox.com/forum/showthread.php/2520-Conditionally-compare-the-data-amp-delete-entire-row

Sub STEP9t() ' https://excelfox.com/forum/showthread.php/2520-Conditionally-compare-the-data-amp-delete-entire-row
Rem 1 Worksheets info
'1_1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
Dim arrS1() As Variant 'Let arrS1() = Ws1.Range("A1").CurrentRegion.Value
Let arrS1() = Ws1.Range("A1:J" & Lr1 & "").Value ' Input data range
'1_2 Alert.xls
Dim Wb2 As Workbook, Ws2 As Worksheet
Set Wb2 = Workbooks("Alert.xls")
Set Ws2 = Wb2.Worksheets.Item(1)
Dim RwCnt2 As Long: Let RwCnt2 = Ws2.Range("A" & Ws2.Rows.Count & "").End(xlUp).Row
'1_2d) second column in Alert.xls
Dim Clm2() As Variant: Let Clm2() = Ws2.Range("B1:B" & RwCnt2 & "").Value

Rem 3
Dim Cnt As Long, MtchRes As Variant
For Cnt = UBound(arrS1(), 1) To 2 Step -1 ' "row" count, Cnt
Select Case arrS1(Cnt, 10) ' column I
Case "BUY" 'If column J of 1.xls has buy then
If arrS1(Cnt, 8) < arrS1(Cnt, 4) Then ' column H of 1.xls is not greater than column D of 1.xls
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If:
Else
End If
Case "" ' If column J of 1.xls has a blank cell then
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If
Case "SHORT" 'If column J is SHORT then
If arrS1(Cnt, 8) > arrS1(Cnt, 4) Then ' column H of 1.xls is Greater than than column D
Let MtchRes = Application.Match(arrWs1(Cnt, 9), Clm2(), 0) ' match column I data of 1.xls with column B of alert.xls
If IsError(MtchRes) Then
' no match result so do nothing
Else
Ws2.Range("A" & MtchRes & ":K" & MtchRes & "").Delete shift:=xlUp ' delete that entire row of alert.xls
End If
Else
End If
End Select
Next Cnt

End Sub

macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Alert.xls : https://app.box.com/s/ectstkrcfnuozys9tmdd0qi3tdvyxb3w

DocAElstein

05-26-2020, 02:16 PM

Macro for this post:
https://excelfox.com/forum/showthread.php/2556-copy-and-paste-of-data-if-matches

Sub AddColumnJValueInWs1basedOnMatchAndCritzeriaInWs2( ) ' https://excelfox.com/forum/showthread.php/2556-copy-and-paste-of-data-if-matches
Rem 1 Worksheets info
'1_1 sample1.xls
Dim Wb1 As Workbook, Ws1 As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb1 = Workbooks("1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Dim arrWs1() As Variant: Let arrWs1() = Ws1.Range("A1").CurrentRegion.Value2
Dim Lr1 As Long: Let Lr1 = UBound(arrWs1(), 1)
'1_1b) data range
Dim arrS1() As Variant 'Let arrS1() = Ws1.Range("A1").CurrentRegion.Value
Let arrS1() = Ws1.Range("A1:J" & Lr1 & "").Value ' Input data range
'1_2 AlertCodes.xlsx
Dim WbA As Workbook, WsA4 As Worksheet
Set WbA = Workbooks("AlertCodes.xlsx")
Set WsA4 = WbA.Worksheets.Item(4)
Dim RwCnt4 As Long: Let RwCnt4 = WsA4.Range("A" & WsA4.Rows.Count & "").End(xlUp).Row
'1_2b) dataa range
Dim arrWsA4() As Variant: Let arrWsA4() = WsA4.Range("A1:K" & RwCnt4 & "").Value2
'1_2d) second column in Alertcodes.xlsx
Dim ClmB() As Variant: Let ClmB() = WsA4.Range("B1:B" & RwCnt4 & "").Value

Rem 3
Dim Cnt As Long
For Cnt = 2 To Lr1 ' going down "rows" in 1.xls
Dim MtchRes As Variant
Let MtchRes = Application.Match(arrWs1(Cnt, 9), ClmB(), 0) ' match column I of 1.xls with sheet4 of column B of Alertcodes.xlsx
If IsError(MtchRes) Then
' do nothing - no match
Else ' look at symbol in column D, 4th worksheet of AlertCodes.xlsx for that matched row in column D, 4th worksheet of AlertCodes.xlsx
If arrWsA4(MtchRes, 4) = ">" Then ' If symbol is > then
Let arrS1(Cnt, 10) = "SHORT" ' put SHORT in column J of 1.xls for the matched row
ElseIf arrWsA4(MtchRes, 4) = "<" Then ' If symbol < then
Let arrS1(Cnt, 10) = "BUY" ' put BUY in column J of 1.xls for the matched row
Else
End If

End If
Next Cnt

Rem 4 Paste back out arrS1()
Let Ws1.Range("A1:J" & Lr1 & "").Value2 = arrS1()
End Sub

AlertCodes.xlsx : https://app.box.com/s/jwpjjut9wt3ej7dbns3269ftlpdr7xsm
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk
Vba.xlsm : https://app.box.com/s/lf6otsrl42m6vxxvycjo04zidya6pd2m

DocAElstein

05-26-2020, 02:16 PM

In support of these posts
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13617&viewfull=1#post13617
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470

sample2BEFORE.csv
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT

"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf

"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf

sampLE2AFTER.csv
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT
,100,,,,,,,,,
,25,,,,,,,,,

"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" & vbCr & vbLf & "," & "100" & "," & "," & "," & "," & "," & "," & "," & "," & "," & vbCr & vbLf & "," & "25" & "," & "," & "," & "," & "," & "," & "," & "," & "," & vbCr & vbLf

"NSE" & "," & "101010" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "22" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "NSE" & "," & "17388" & "," & "6" & "," & Chr(60) & "," & "12783" & "," & "A" & "," & "," & "," & "," & "," & "GTT" &
vbCr & vbLf & "," & "100" & "," & "," & "," & "," & "," & "," & "," & "," & "," &
vbCr & vbLf & "," & "25" & "," & "," & "," & "," & "," & "," & "," & "," & "," &
vbCr & vbLf

https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13617&viewfull=1#post13617
sampLE2AFTER.csv : https://drive.google.com/file/d/1TyfOWXhZ9Psg7Z4XhngWwzZ3s43YxzwA
sample2BEFORE : https://drive.google.com/file/d/1X2MdidDmJ886I6HwJLvIqNATRC34o5hD

app.box.com
Share ‘sample2BEFORE.csv’ : https://app.box.com/s/d8lu7iatfv6h8spp9eru8asm3h4v4e4p
Share ‘Sample2After.csv’ : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu

Previous files:
sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
Sample2After.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo

DocAElstein

05-26-2020, 02:16 PM

Macro for this post:
https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13617&viewfull=1#post13617

Sub VBAAppendDataToTextFileLineBasedOnTheTextFileAndEx celFileConditions2() ' https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13616&viewfull=1#post13616
Rem 1 Workbook, Worksheet info ( Excel File )
Dim Wb As Workbook, Ws As Worksheet
' Set Wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Sample1.xls")
' Set Wb = Workbooks.Open(ThisWorkbook.Path & Application.PathSeparator & "Sample1.xls")
Set Wb = Workbooks("1.xls") ' Workbooks("Sample1.xls") ' CHANGE TO SUIT
Set Ws = Wb.Worksheets.Item(1)
Dim arrWs() As Variant: Let arrWs() = Ws.Range("A1").CurrentRegion.Value2
Dim LR As Long: Let LR = UBound(arrWs(), 1)
Rem 2 text File Info, Import into Excel Array
Dim PathAndFileName As String, TotalFile As String
' Let PathAndFileName = ThisWorkbook.Path & "\" & "Alert 24 Mai..csv" '
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "sample2BEFORE.csv" ' "sample2_9June.csv" ' "sample2 8June.csv" ' "Sample2.csv" ' "sample2 ef 5 June.csv" ' CHANGE TO SUIT From Avinash : https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470&viewfull=1#post13470 sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
' 2a)(i) Determine rows (records) wanted, based on ... First column(field) not being empty
Dim RwCnt As Long, TextFileLineIn As String
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open PathAndFileName For Input As #FileNum 'Open Route to data
Line Input #FileNum, TextFileLineIn ' First line
Do While Not EOF(FileNum) = True And Left(TextFileLineIn, 4) = "NSE," ' Left(TextFileLineIn, 4) = "NSE," ' For text file lines like NSE,101010,6,<,12783,A,,,,,GTT that may have extra unwanted lines like in one Avinash uses stupidly for explanations
Let RwCnt = RwCnt + 1 ' for first and subsequent lines given by below. ... but
Line Input #FileNum, TextFileLineIn ' next line in text file
Loop
If EOF(FileNum) = True Then Let RwCnt = RwCnt + 1 ' ... but if the last line I want is EOF, I will not catch it in the loop so must add a 1 here
Close #FileNum
' 2a)(ii) get the text file as a long single string
Let FileNum = FreeFile(1)
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by vbCr & vbLf ( Note vbCr & vbLf = vbNewLine )
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)
'Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' Alert 24 MaiDotDotcsvBefore.JPG : https://imgur.com/jSZV7Bt , https://imgur.com/ckS9Rzq
' 2c) ' we can now make an array for all the rows, and we know our columns are A-K = 11 columns
Dim arrIn() As String: ReDim arrIn(1 To RwCnt, 1 To 11)
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data but only those up to Rwcnt
Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To 11
'For Clm = 1 To UBound(arrClms()) + 1
Let arrIn(Cnt, Clm) = arrClms(Clm - 1)
Dim TruncRw As String '_-
Let TruncRw = TruncRw & arrIn(Cnt, Clm) & "," '_- The idea of this is a bodge to get rid of a lot of extra ,,,,,,, if we have empty cells being used, as in Avinash original - sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t - https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13475&viewfull=1#post13475
Next Clm
Let arrRws(Cnt - 1) = Left(TruncRw, Len(TruncRw) - 1) '_- take off the last ,
Let TruncRw = "" '_- so this can be used again for next line(row)
Next Cnt
' 2d) Re make text string of just rows to RwCnt
ReDim Preserve arrRws(0 To RwCnt - 1)
Dim TotalFileToRwCnt As String
Let TotalFileToRwCnt = Join(arrRws(), vbCr & vbLf) & vbCr & vbLf ' This is effectively our long string text file and an extra final carriage return and line feed
' 2d) second column in text file, up to RwCnt
Dim Clm2() As Variant: Let Clm2() = Application.Index(arrIn(), 0, 2) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Clm2Sample2csv.JPG : https://imgur.com/DYYAl3z

Rem 3 Do it
For Cnt = 2 To LR ' considering each data row in Sample1.xls
' ( If column K of sample1.xls is greater than Column D of sample1.xls & Column H of sample1.xls is Greater than column K of sample1.xls ) or ( If column K of sample1.xls is lower than Column D of sample1.xls & Column H of sample1.xls is lower than column K of sample1.xls ) Then
' Condition 1) or Condition 2)
If (arrWs(Cnt, 11) > arrWs(Cnt, 4) And arrWs(Cnt, 8) > arrWs(Cnt, 11)) Or (arrWs(Cnt, 11) < arrWs(Cnt, 4) And arrWs(Cnt, 8) < arrWs(Cnt, 11)) Then
Dim MtchRes As Variant ' for match column I of of Sample1.xls with second data column of text file Sample2.csv Clm2()
Let MtchRes = Application.Match(CStr(arrWs(Cnt, 9)), Clm2(), 0) ' match column I of of 1.xls with second column data of text file of Alert..csv
' Match Column I of sample1.xls with second field values (column B) of sample2.csv
If Not IsError(MtchRes) Then ' if it is there then do nothing
' match obtsained do nothing
Else ' it is not present paste the column I data of sample1.xls to append second field values (column B) of sample2.csv
Let TotalFileToRwCnt = TotalFileToRwCnt & "," & arrWs(Cnt, 9) & ",,,,,,,,,," & vbCr & vbLf ' make the single text string for the output text file
End If

Else
' Neither of the 2 conditions are met so do nothing
End If

Next Cnt

Rem 5 remake the text file
''5a) make a new text file string
'Dim strTotalFile As String
' Let strTotalFile = Join(arrRwsOut(), vbCr & vbLf)
'5b) make new file
Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Open ThisWorkbook.Path & "\" & "Sample2After.csv" For Output As #FileNum ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum, TotalFileToRwCnt ' strTotalFile
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToR wCnt)

Rem 6 Check File in Excel VBA open
' Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Sample2.csv"
' Workbooks.Open Filename:=ThisWorkbook.Path & Application.PathSeparator & "Sample2After.csv" ' CHANGE TO SUIT
'Dim Wb As Workbook
' Set Wb = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\sample2.csv")
End Sub

Share ‘sample2BEFORE.csv’ : https://app.box.com/s/d8lu7iatfv6h8spp9eru8asm3h4v4e4p
Share ‘Sample2After.csv’ : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
vba.xlsm : https://app.box.com/s/juekenyll42z84j6ms7qonzsngnugoyo
Sample1.xls : https://app.box.com/s/xh58fgjl74w06hvsd53jriqkohdm6a3q
macro.xlsm : https://app.box.com/s/z358r7tbc9hzthi539dlj49jsf4gyg8p
1.xls : https://app.box.com/s/38aoip5xi7018y9syt0xe4g04u95l6xk

DocAElstein

05-30-2020, 12:49 PM

Question 1

Solution for this question, ( 2020-05-28 22:13:09 Rajesh Kumar )
https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html

Question: ( Question 1 )
......I have a list of 80 students. I have made 80 sheets, 1 sheet for 1 student. I want to rename these 80 sheets on the basis of the name in the list, so that whenever I update the name list, the corresponding sheet-name changed automatically. I'm a beginner in this field. Please help me.

Solution.
Hello Rajesh
This requirement is fairly easy with VBA

There are 3 macros which I have written for you, and I am returning 2 workbook examples

Macro for your original requirement
Private Sub Worksheet_Change(ByVal Target As Range)
This macro is in both workbooks:
It does this: If you change any of your names in column B of the worksheets, then the name of the corresponding worksheet tab Name will change, as per your main original requirement.

Workbook AddNamesfromListToExistingWorksheets.xlsm
This is the workbook supplied by you. It has initially 80 student names in column B of the first worksheet. It has 80 additional worksheets , as made by you, with the names of 1 2 3 4 5 …. Etc.
This workbook has a macro , Sub ChangeNamesToExistingWorksheets() . This macro replaces those names with the names from the Student name list in column B

Workbook AddWorksheetsNamedFromList.xlsm
This is your original Workbook, with all but the first worksheet deleted. So this only contains one worksheet containing your list of student Names in column B
In this workbook, there is a macro, Sub AddWorksheetsfromListOfNames()
This macro adds worksheets with the student Names

Note: in your supplied data, you had two identical names at row 26 and at row 75, SACHIN KUMAR , so I changed it to SACHIN KUMAR 2 in row 75
( We could handle such cases in coding, automatically, later if you preferred )

Alan

Workbooks:
Share ‘AddNamesfromListToExistingWorksheets.xlsm’ : https://app.box.com/s/2ytj6qrsyaudh3tzgtodls8l05zn1woz
Share ‘AddWorksheetsNamedFromList.xlsm’ : https://app.box.com/s/yljwyk5ykxtjt2qhzvdpwcrft19phx54
For macros, see also post https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13444

Cross posts
https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ( 2020-05-28 22:13:09 Rajesh Kumar ) https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html
https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/ https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/

DocAElstein

05-30-2020, 01:30 PM

Macros for this post ( Question 1 )
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13443

Option Explicit

' https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13443 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13443&viewfull=1#post13444

Sub RemoveAllButThisWorksheet()
Dim Cnt
For Cnt = ThisWorkbook.Worksheets.Count To 2 Step -1 ' second worksheet counting tab from the left is worksheets item 2
Let Application.DisplayAlerts = False
ThisWorkbook.Worksheets.Item(Cnt).Delete
Let Application.DisplayAlerts = True
Next Cnt
End Sub
Sub ChangeNamesToExistingWorksheets() '
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Name List") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant ' The .Value2 property in the next line will return a field of values housed in Variant type Elements, so we need to give the variant type to our array used to capture that array of values
Let arrNmes() = Ws1.Range("B1:B" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 2 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 2 ( column B )
Let Worksheets.Item(Cnt).Name = arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub

Sub AddWorksheetsfromListOfNames()
Rem 0
On Error GoTo Bed
Let Application.EnableEvents = False
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Name List") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("B1:B" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 2 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 2
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt

Bed:
Let Application.EnableEvents = True
End Sub
'
'

Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 As Long
Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )

Dim Rng As Range
Set Rng = Ws1.Range("B2:B" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
Let ThisWorkbook.Worksheets.Item(Rw).Name = Target.Value ' In the list, each row number corresponds to the item number of our worksheets made from that list
Else
' changed cell was not in Student name list
End If

End Sub

Cross posts
https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html ( 2020-05-28 22:13:09 Rajesh Kumar ) https://excel.tips.net/T002145_Dynamic_Worksheet_Tab_Names.html
https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/ https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/

DocAElstein

05-31-2020, 12:56 PM

Macro for these posts ( Question 2 )
https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13442&viewfull=1#post13442
https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13448&viewfull=1#post13448

' _1. I want to create 5 tabs (Sheets) on the basis of these 5 names. (Now the workbook will have 6 tabs, including Master Sheet) https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445
Sub AddWorksheetsfromListOfNames2() ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445 https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("A1:A" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 1 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 1 ( Column A )
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt

Bed:
Let Application.EnableEvents = True
End Sub ' (Now the workbook will have 6 tabs, including Master Sheet)

Sub AddHypolinkToWorksheet() ' https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("A1:A" & Lr1 & "").Value2

Rem 2 Add hyperlinks
Ws1.Hyperlinks.Delete
Dim Cnt
For Cnt = 1 To Lr1 ' ='F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\[DynamicWorksheetNamesLinkHideBasedOnCellValue.xlsm]RAHIM'!$A$1
Dim Paf As String: Let Paf = "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt, 1) & "'!$A$1"
' Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:="='" & arrNmes(Cnt, 1) & "'!A1", ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )

Dim Rng As Range
Set Rng = Ws1.Range("A1:A" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
If Target.Value = "" Then ' 5. If I delete the content of A1 (ANUJ), i.e, if cell A1 is blank, the corresponding sheet "ANUJ" should hide automatically.
ThisWorkbook.Worksheets.Item(Rw + 1).Visible = False
Exit Sub
Else
ThisWorkbook.Worksheets.Item(Rw + 1).Visible = True
Let ThisWorkbook.Worksheets.Item(Rw + 1).Name = Target.Value ' In the list, each row number corresponds to one less than the item number of our worksheets made from that list
End If
Else
' changed cell was not in Student name list
End If

'
Call AddHypolinkToWorksheet
End Sub

Share ‘DynamicWorksheetNamesLinkHideBasedOnCellValu e. : https://app.box.com/s/louq07ga6uth1508e572l7zr9fakont9

DocAElstein

06-01-2020, 02:32 PM

Macros for this post
https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456

Add Workseets from names list, for example from :

_____ Workbook: DynamicWorksheetNamesLinkHideBasedOnCellValueC.xls m ( Using Excel 2007 32 bit )
Row\Col
B
C
D

3

4ANUJ

5RITA

6MUKESH

7RAM

8RAHIN

9Anshu

10
Worksheet: Master Sheet

' _1. I want to create tabs (Sheets) on the basis of names. https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456 https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445
Sub AddWorksheetsfromListOfNamesC() ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456 https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13445#post13445 https://www.mrexcel.com/board/threads/vba-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-value.1135674/
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("C4:C" & Lr1 & "").Value2 ' Range("A1:A" & Lr1 & "").Value2
Rem 2 Add and name worksheets from list
Dim Cnt As Long
For Cnt = 1 To UBound(arrNmes(), 1) ' From (2,1) To (2,Lr1) in names array list column 1 ( Column A )
Worksheets.Add After:=Worksheets.Item(Worksheets.Count)
Let ActiveSheet.Name = arrNmes(Cnt, 1)
Next Cnt
Worksheets.Item(1).Select
Bed:
Let Application.EnableEvents = True
End Sub '

Add hypelinks to Worksheets

Sub AddHypolinkToWorksheet()
Rem 0
On Error GoTo Bed ' If we have problems then we want to make sure that we still re enable Events coding before ending the macro
Let Application.EnableEvents = False ' This will prevent anything we do in this macro from causing erratic working of any automatic event coding
Rem 1 worksheets 1 info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item(1) ' or Worksheets("Master Sheet") ' first worksheet counting tab from the left is worksheets item 1
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
Dim arrNmes() As Variant
Let arrNmes() = Ws1.Range("C4:C" & Lr1 & "").Value2 ' Range("A1:A" & Lr1 & "").Value2

Rem 2 Add hyperlinks
Ws1.Hyperlinks.Delete
Dim Cnt
For Cnt = 4 To Lr1 ' ='F:\Excel0202015Jan2016\OffenFragensForums\AllenW yatt\[DynamicWorksheetNamesLinkHideBasedOnCellValue.xlsm]RAHIM'!$A$1
Dim Paf As String: Let Paf = "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt - 3, 1) & "'!$A$1" ' "='" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & arrNmes(Cnt, 1) & "'!$A$1"
' Ws1.Hyperlinks.Add Anchor:=Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:="='" & arrNmes(Cnt, 1) & "'!A1", ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Ws1.Hyperlinks.Add Anchor:=Ws1.Range("C" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt - 3, 1), TextToDisplay:=arrNmes(Cnt - 3, 1) ' Ws1.Range("A" & Cnt & ""), Address:="", SubAddress:=Paf, ScreenTip:=arrNmes(Cnt, 1), TextToDisplay:=arrNmes(Cnt, 1)
Next Cnt
Bed: ' error handling code section.
Let Application.EnableEvents = True
End Sub
'

Event macros

'
Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' https://excelfox.com/forum/showthread.php/2501-VBA-for-dynamic-sheets-name-dynamic-link-hide-sheets-based-on-a-cell-Value?p=13456&viewfull=1#post13456
'If Target.Column = 1 And Not IsArray(Target.Value) Then ' we are in column A , And we selected one cell
If Target.Column = 3 And Not IsArray(Target.Value) Then ' we are in column C , And we selected one cell
Set LRng = Target
Else

End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If IsArray(Target.Value) Then Exit Sub ' If we have changed more than 1 cell, our code lines below will error, so best do nothing in such a case
Dim Ws1 As Worksheet
Set Ws1 = Me
Dim Lr1 As Long
Let Lr1 = Ws1.Range("C" & Ws1.Rows.Count & "").End(xlUp).Row ' Range("A" & Ws1.Rows.Count & "").End(xlUp).Row ' http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. )
If Not LRng Is Nothing And Target.Value = "" And LRng.Row = Lr1 + 1 Then Let Lr1 = Lr1 + 1
Dim Rng As Range
Set Rng = Ws1.Range("C4:C" & Lr1 & "") ' Ws1.Range("A1:A" & Lr1 & "")
If Not Intersect(Rng, Target) Is Nothing Then ' The Excel VBA Application.Intersect method returns the range where all the given ranges cross, or Nothing if there are no common cells. So, in this example, we would have Nothing if our selection ( which VBA supplies in Target ) , did not cross our names list ' https://docs.microsoft.com/en-us/office/vba/api/excel.application.intersect
Dim Rw As Long
Let Rw = Target.Row
If Target.Value = "" Or Target.Value = "-" Then ' 5. If I delete the content of A1 (ANUJ), i.e, if cell A1 is blank, the corresponding sheet "ANUJ" should hide automatically.
Let Application.EnableEvents = False
Let Target.Value = ""
Let Application.EnableEvents = True
' ThisWorkbook.Worksheets.Item(Rw + 1).Visible = False
ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Visible = False
Exit Sub
Else
' ThisWorkbook.Worksheets.Item(Rw + 1).Visible = True
' Let ThisWorkbook.Worksheets.Item(Rw + 1).Name = Target.Value ' In the list, each row number corresponds to one less than the item number of our worksheets made from that list
ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Visible = True
Let ThisWorkbook.Worksheets.Item(Rw + 1 - 3).Name = Target.Value
End If
Else
' changed cell was not in Student name list
End If

'
Call AddHypolinkToWorksheet
End Sub

Top 2 lines of code module

Option Explicit
Dim LRng As Range

File:
DynamicWorksheetNamesLinkHideBasedOnCellValueC.xls m : https://app.box.com/s/alo1fbzx8r41jd81rttghikytqzvm0w9

DocAElstein

06-07-2020, 09:07 PM

kkfhhfsfhsah

DocAElstein

06-08-2020, 08:39 PM

In suppot of this forum post
https://www.excelforum.com/excel-programming-vba-macros/1317589-conditionally-compare-the-data-and-delete-entire-row.html#post5340103

' Alert 29May excelforum..csv https://www.excelforum.com/excel-programming-vba-macros/1317589-conditionally-compare-the-data-and-delete-entire-row.html
'If column J of 1.xls has buy & column H of 1.xls is not greater than column D of 1.xls
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv
'If column J of 1.xls has a blank cell
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv
'If column J of 1.xls has short & column H of 1.xls is Greater than than column D of 1.xls
' then match column I data of 1.xls with column B of alert.csv and
' if it matches then delete that entire row of alert.csv

' With Sheets(1)
' Lr = .Range("a" & Rows.Count).End(xlUp).Row

' Missed 3 dots.
' With GetObject(fn)
' With .Sheets(1)
' Lr = .Range("a" & .Rows.Count).End(xlUp).Row
Sub OpenAlert29Mayexcelforum__csv()
Workbooks.Open Filename:=ThisWorkbook.Path & "\Alert 29May excelforum..csv"
End Sub

Sub JindonsTesties() ' Conditionally compare the data & delete entire row - https://www.excelforum.com/excel-programming-vba-macros/1317589-conditionally-compare-the-data-and-delete-entire-row.html#post5340103
' PART 1 ================================
Dim LR As Long, e ', fn As String ' , myCSV As String, txt As String, vTemp As Variant, arrTemp() As Variant
Rem 1 Workbooks, Worksheets info
' fn = ThisWorkbook.Path & "\1.xls" '"C:\Users\WolfieeeStyle\Desktop\1.xls"
' myCSV = ThisWorkbook.Path & "\Alert 29May excelforum..csv" ' "C:\Users\WolfieeeStyle\Desktop\Alert..csv"
' If (Dir(fn) = "") + (Dir(myCSV) = "") Then MsgBox "Invalid file Path/Name": Exit Sub
Dim Wb1 As Workbook
Set Wb1 = Workbooks("1.xls") ' CHANGE TO SUIT
' Set Wb1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") ' CHANGE TO SUIT
'With GetObject(fn)
'With .Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = Wb1.Worksheets.Item(1)
Let LR = Ws1.Range("a" & Ws1.Rows.Count).End(xlUp).Row ' 1.xls last row of data
Rem 2 Make 1 Dimensional arrays for values
'2a) If column J of 1.xls has buy & column H of 1.xls is not greater than column D of 1.xls
'Let vTemp = .Evaluate("transpose(if((j2:j" & LR & "=""buy"")*(h2:h" & LR & "<d2:d" & LR & "),i2:i" & LR & "))")
Dim arrTemp() As Variant
Let arrTemp() = Ws1.Evaluate("transpose(if((j2:j" & LR & "=""buy"")*(h2:h" & LR & "<d2:d" & LR & "),i2:i" & LR & "))")
Dim txt As String
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is empty
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'2b) If column J of 1.xls has short & column H of 1.xls is Greater than column D of 1.xls
' Let vTemp = .Evaluate("transpose(if((j2:j" & LR & "=""short"")*(h2:h" & LR & ">d2:d" & LR & "),i2:i" & LR & "))")
Let arrTemp() = Ws1.Evaluate("transpose(if((j2:j" & LR & "=""short"")*(h2:h" & LR & ">d2:d" & LR & "),i2:i" & LR & "))")
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is {100}
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'2c) If column J of 1.xls has a blank
' Let vTemp = .Evaluate("transpose(if(j2:j" & LR & "="""",i2:i" & LR & "))")
Let arrTemp() = Ws1.Evaluate("transpose(if(j2:j" & LR & "="""",i2:i" & LR & "))")
For Each e In Filter(arrTemp(), False, 0) ' Filter(arrTemp(), False, 0) is {15083, 17388}
Let txt = txt & " And (Not F2 = " & e & ")"
Next
'End With ' final txt is And (Not F2 = 15083) And (Not F2 = 17388) And (Not F2 = 100)
'.Close
'End With
' CreateNew myCSV, Mid$(txt, 5)
' Let txt = Mid$(txt, 6) ' take off the first " AND "

' Part 2 ================================================== =============================
'End Sub
'Sub MyTests_CreateNew()
Rem 3 source text file
'3a) source text file
Dim myCSV As String ' , txt As String
Let myCSV = ThisWorkbook.Path & "\Alert 29May excelforum..csv" ' "C:\Users\WolfieeeStyle\Desktop\Alert..csv"
' Call CreateNew(myCSV, Mid$(txt, 5))
'End Sub
'Private Sub CreateNew(myCSV As String, txt As String)
Dim fn As String ' , cn As Object, rs As Object, x
' 3b Make copy of test file , make temporary file
fn = Left$(myCSV, InStrRev(myCSV, "\")) & "tempComma.csv"
Dim PathAndFileName As String: Let PathAndFileName = fn
FileCopy myCSV, fn ' FileCopy source, destination https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/filecopy-statement

Rem 4 ADODB stuff
'4a)
Dim Cn As Object: Set Cn = CreateObject("ADODB.Connection")
With Cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Text;HDR=No;"
'.Open Left(fn, InStrRev(fn, "\"))
Dim PathOnly As String: Let PathOnly = Left(fn, InStrRev(fn, "\"))
.Open PathOnly
End With
'4b)
Let txt = Mid$(txt, 6) ' (Not F2 = 15083) And (Not F2 = 17388) And (Not F2 = 100)
Dim Rs As Object: Set Rs = CreateObject("ADODB.Recordset")
Rs.Open "Select * From [tempComma.csv] Where " & txt, Cn, 3
Dim x As String
Let x = Rs.GetString(, , ",", vbCrLf): Debug.Print x

Set Cn = Nothing: Set Rs = Nothing
Rem 5
Kill fn
Rem 6
Open Replace(myCSV, ".csv", "_Filtered.csv") For Output As #1
Print #1, x;
Close #1
End Sub

DocAElstein

06-08-2020, 08:39 PM

In suppot of this forum post
https://excelfox.com/forum/showthread.php/2518-convert-the-data-from-xlsx-to-txt-file
https://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13348

' 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
Sub WtchaGot_Unic_NotMuchIfYaChoppedItOff(ByVal strIn As String) '
Rem 1 ' Output "sheet hardcopies"
'1a) Worksheets 'Make Temporary Sheets, if not already there, in Current Active Workbook, for a simple list of all characters, and for pasting the string into worksheet cells
'1a)(i) Full list of characters worksheet
If Not Evaluate("=ISREF(" & "'" & "WotchaGotInString" & "'!Z78)") Then ' ( the ' are not important here, but in general allow for a space in the worksheet name like "Wotcha Got In String"
Dim Wb As Workbook ' ' ' Dim: ' Preparing a "Pointer" to an Initial "Blue Print" in Memory of the Object ( Pigeon Hole with a bit of paper or code lines on that can be filled in to refer to a specific Objec of this type ) . This also us to get easily at the Methods and Properties throught the applying of a period ( .Dot) ( intellisense ) '
Set Wb = ActiveWorkbook ' ' Set now (to Active Workbook - one being "looked at"), so that we carefull allways referrence this so as not to go astray through Excel Guessing inplicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 '
Wb.Worksheets.Add After:=Wb.Worksheets.Item(Worksheets.Count) 'A sheeet is added and will be Active
Dim Ws As Worksheet '
Set Ws = ActiveSheet 'Rather than rely on always going to the active sheet, we referr to it Explicitly so that we carefull allways referrence this so as not to go astray through Excel Guessing implicitly not the one we want... Set: Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191 ' Values are filled at the memory locations and the directions there are specified in the variable "Blue Print "Pointer". In this case a Filled in Blue Print is passed. http://www.excelforum.com/excel-programming-vba-macros/1138804-help-understanding-class-instancing-cant-set-ws-new-worksheet-intellisense-offers-it-4.html#post4387191
Ws.Activate: Ws.Cells(1, 1).Activate ' ws.Activate and activating a cell sometimes seemed to overcome a strange error
Let Ws.Name = "WotchaGotInString"
Else ' The worksheet is already there , so I just need to set my variable to point to it
Set Ws = ThisWorkbook.Worksheets("WotchaGotInString")
End If
'1a(ii) Worksheet to paste out string into worksheet cells
If Not Evaluate("=ISREF(" & "'" & "StrIn|WtchaGot" & "'!Z78)") Then
Set Wb = ActiveWorkbook
Wb.Worksheets.Add After:=Wb.Worksheets.Item(1)
Dim Ws1 As Worksheet
Set Ws1 = ActiveSheet
Ws1.Activate: Ws1.Cells(1, 1).Activate
Let Ws1.Name = "StrIn|WtchaGot"
Else
Set Ws1 = ThisWorkbook.Worksheets("StrIn|WtchaGot")
End If
'1b) Array
Dim myLenf As Long: Let myLenf = Len(strIn) ' ' Long is very simple to handle, - final memory "size" type is known (123.456 and 000.001 have same "size" computer memory ) , and so a Address suggestion can be given for the next line when the variable is filled in. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. ) https://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html
Dim arrWotchaGot() As String: ReDim arrWotchaGot(1 To myLenf + 1, 1 To 2) ' +1 for header Array for the output 2 column list. The type is known and the size, but I must use this ReDim method simply because the dim statement Dim( , ) is complie time thing and will only take actual numbers
Let arrWotchaGot(1, 1) = Format(Now, "DD MMM YYYY") & vbLf & "Lenf is " & myLenf: Let arrWotchaGot(1, 2) = Left(strIn, 40)
Rem 2 String anylaysis
'Dim myLenf As Long: Let myLenf = Len(strIn)
Dim Cnt As Long
For Cnt = 1 To myLenf ' ===Main Loop============================================== ==========================
' Character analysis: Get at each character
Dim Caracter As Variant ' String is probably OK.
Let Caracter = Mid(strIn, Cnt, 1) ' ' the character in strIn at position from the left of length 1
'2a) The character added to a single WotchaGot long character string to look at and possibly use in coding
Dim WotchaGot As String ' This will be used to make a string that I can easilly see and also is in a form that I can copy and paste in a code line required to build the full string of the complete character string
'2a)(i) Most common characters and numbers to be displayed as "seen normally" ' -------2a)(i)--
If Caracter Like "[A-Z]" Or Caracter Like "[0-9]" Or Caracter Like "[a-z]" Then ' Check for normal characters
'SirNirios
If Not Cnt = 1 Then ' I am only intersted in next line comparing the character before, and if i did not do this the next line would error if first character was a "normal" character
If Not Cnt = myLenf And (Mid(strIn, Cnt - 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt - 1, 1) Like "[0-9]" Or Mid(strIn, Cnt - 1, 1) Like "[a-z]") Then ' And (Mid(strIn, Cnt + 1, 1) Like "[A-Z]" Or Mid(strIn, Cnt + 1, 1) Like "[0-9]" Or Mid(strIn, Cnt + 1, 1) Like "[a-z]") Then
Let WotchaGot = WotchaGot & "|LinkTwoNormals|"
Else
End If
Else
End If
Let WotchaGot = WotchaGot & """" & Caracter & """" & " & " ' This will give the sort of output that I need to write in a code line, so for example if I have a123 , this code line will be used 4 times and give like a final string for me to copy of "a" & "1" & "2" & "3" & I would phsically need to write in code like strVar = "a" & "1" & "2" & "3" - i could of course also write = "a123" but the point of this routine is to help me pick out each individual element
Else ' Some other things that I would like to "see" normally - not "normal simple character" - or by a VBA constant, like vbCr vbLf vbTab
Select Case Caracter ' 2a)(ii)_1
Case " "
Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case "!"
Let WotchaGot = WotchaGot & """" & "!" & """" & " & "
Case "$"
Let WotchaGot = WotchaGot & """" & "$" & """" & " & "
Case "%"
Let WotchaGot = WotchaGot & """" & "%" & """" & " & "
Case "~"
Let WotchaGot = WotchaGot & """" & "~" & """" & " & "
Case "&"
Let WotchaGot = WotchaGot & """" & "&" & """" & " & "
Case "("
Let WotchaGot = WotchaGot & """" & "(" & """" & " & "
Case ")"
Let WotchaGot = WotchaGot & """" & ")" & """" & " & "
Case "/"
Let WotchaGot = WotchaGot & """" & "/" & """" & " & "
Case "\"
Let WotchaGot = WotchaGot & """" & "\" & """" & " & "
Case "="
Let WotchaGot = WotchaGot & """" & "=" & """" & " & "
Case "?"
Let WotchaGot = WotchaGot & """" & "?" & """" & " & "
Case "'"
Let WotchaGot = WotchaGot & """" & "'" & """" & " & "
Case "+"
Let WotchaGot = WotchaGot & """" & "+" & """" & " & "
Case "-"
Let WotchaGot = WotchaGot & """" & "-" & """" & " & "
Case "_"
Let WotchaGot = WotchaGot & """" & "_" & """" & " & "
Case "."
Let WotchaGot = WotchaGot & """" & "." & """" & " & "
Case ","
Let WotchaGot = WotchaGot & """" & "," & """" & " & "
Case ";"
Let WotchaGot = WotchaGot & """" & ";" & """" & " & "
Case ":"
Let WotchaGot = WotchaGot & """" & ":" & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' ' 2a)(ii)_2
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
' Case " "
' Let WotchaGot = WotchaGot & """" & " " & """" & " & "
Case vbCr
Let WotchaGot = WotchaGot & "vbCr & " ' I actuall would write manually in this case like vbCr &
Case vbLf
Let WotchaGot = WotchaGot & "vbLf & "
Case vbCrLf
Let WotchaGot = WotchaGot & "vbCrLf & "
Case vbNewLine
Let WotchaGot = WotchaGot & "vbNewLine & "
Case """" ' This is how to get a single " No one is quite sure how this works. My theory that, is as good as any other, is that syntaxly """" or " """ or """ " are accepted. But in that the """ bit is somewhat strange for VBA. It seems to match the first and Third " together as a valid pair but the other " in the middle of the 3 "s is also syntax OK, and does not error as """ would because of the final 4th " which it syntaxly sees as a valid pair matched simultaneously as it does some similar check on the first and Third as a concluding string pair. All is well except that the second " is captured within a accepted enclosing pair made up of the first and third " At the same time the 4th " is accepted as a final concluding " paired with the second which it is using but at the same time now isolated from.
Let WotchaGot = WotchaGot & """" & """" & """" & """" & " & " ' The reason why "" "" would not work is that at the end of the "" the next empty character signalises the end of a string pair, and only if it saw a " would it keep checking the syntax rules which then lead in the previous case to the situation described above.
Case vbTab
Let WotchaGot = WotchaGot & "vbTab & "
' 2a)(iii)
Case Else
If AscW(Caracter) < 256 Then
Let WotchaGot = WotchaGot & "Chr(" & AscW(Caracter) & ")" & " & "
Else
Let WotchaGot = WotchaGot & "ChrW(" & AscW(Caracter) & ")" & " & "
End If
'Let CaseElse = Caracter
End Select
End If ' End of the "normal simple character" or not ' -------2a)------Ended-----------
'2b) A 2 column Array for convenience of a list
Let arrWotchaGot(Cnt + 1, 1) = Cnt & " " & Caracter: Let arrWotchaGot(Cnt + 1, 2) = AscW(Caracter) ' +1 for header
Next Cnt ' ========Main Loop============================================== ===================================
'2c) Some tidying up
If WotchaGot <> "" Then
Let WotchaGot = Left(WotchaGot, Len(WotchaGot) - 3) ' take off last " & " ( 2 spaces one either side of a & )
Let WotchaGot = Replace(WotchaGot, """ & |LinkTwoNormals|""", "", 1, -1, vbBinaryCompare)
' The next bit changes like this "Lapto" & "p" to "Laptop" You might want to leave it out ti speed things up a bit
If Len(WotchaGot) > 5 And (Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 1, 1) Like "[a-z]") And (Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[A-Z]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[0-9]" Or Mid(WotchaGot, Len(WotchaGot) - 7, 1) Like "[a-z]") And Mid(WotchaGot, Len(WotchaGot) - 6, 5) = """" & " & " & """" Then
Let WotchaGot = Left$(WotchaGot, Len(WotchaGot) - 7) & Mid(WotchaGot, Len(WotchaGot) - 1, 2) ' Changes like this "Lapto" & "p" to "Laptop"
Else
End If
Else
End If
Rem 3 Output
'3a) String
'3a)(i)
MsgBox Prompt:=WotchaGot: Debug.Print WotchaGot ' Hit Ctrl+g from the VB Editor to get a copyable version of the entire string
'3a)(ii)
Ws1.Activate: Ws1.Cells.Item(1, 1).Activate
Let Ws1.Range("A1").Value = strIn
Let Ws1.Range("B1").Value = WotchaGot
'3b) List
Dim NxtClm As Long: Let NxtClm = 1 ' In conjunction with next If this prevents the first column beine taken as 0 for an empty worksheet
Ws.Activate: Ws.Cells.Item(1, 1).Activate
If Not Ws.Range("A1").Value = "" Then Let NxtClm = Ws.Cells.Item(1, Columns.Count).End(xlToLeft).Column + 1
Let Ws.Cells.Item(1, NxtClm).Resize(UBound(arrWotchaGot(), 1), UBound(arrWotchaGot(), 2)).Value = arrWotchaGot()
Ws.Cells.Columns.AutoFit
End Sub
'

DocAElstein

06-10-2020, 02:09 PM

lKSHFLhlhfl

DocAElstein

06-10-2020, 02:09 PM

lKSHFLhlhfl

DocAElstein

06-10-2020, 02:09 PM

lKSHFLhlhfl

DocAElstein

06-10-2020, 02:09 PM

test ...

test

skjfSKJHFkjhfKJSHFSKJHFskjhf

Different File Types used for simple values
See here ( This post https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13349 )
for typical comparisons of text Files, Excel files, and data files
Text File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13693&viewfull=1#post13693
Excel File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13694&viewfull=1#post13694
Data File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13695&viewfull=1#post13695

Function to make an Excel files from a text file containing values and separators

XLFlNme is the Excel File name wanted for the new File
TxtFlNme is Text File name of an existing text file
valSep is the values separator used in the existing text file##
LineSep is the line separator used in thee existing text file##
Paf it the path to the files. ( I assume they are at the same place for the existing text file and the new Excel File )

The function is almost identical to the macro I did for you here: Code for Text File to Excelhttps://eileenslounge.com/viewtopic.php?p=269105#p269105
The function is here: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13717&viewfull=1#post13717

It is a function.
So you will need to call it with a test macro such as this:

' https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx
Sub Test_MakeXLFileusingvaluesInTextFile()
Dim Pf As String
Let Pf = ThisWorkbook.Path ' ' CHANGE TO SUIT
'let pf = "C:\Users\WolfieeeStyle\Desktop" ' CHANGE TO SUIT
Call MakeXLFileusingvaluesInTextFile(Pf, "sample2BEFORE..csv", "Test.xlsx", ",", vbCr & vbLf)
End Sub

I tested it using this text file: Share ‘sample2BEFORE..csv’ : https://app.box.com/s/a3o4irgofydb71e3o0c4aaxefg6dw3bi
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT

Running the test macro results in an Excel File being made looking like this:

_____ Workbook: Test.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKL
1NSE1010106<12783AGTT

2NSE226<12783AGTT

3NSE173886<12783AGTT

4
Worksheet: Sheet1

DocAElstein

06-10-2020, 02:09 PM

lKSHFLhlhfl

DocAElstein

06-11-2020, 03:22 PM

Just testing links to Threads

( This post is https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13349 )

Some notes related to these posts

https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx https://excelfox.com/forum/showthread.php/2467-VBA-To-Copy-Rows-From-One-Workbook-To-text-csv-File-Based-On-Count-In-A-Different-Workbook?p=13318&viewfull=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtopic.php?f=30&t=34497&p=267706#p267706
http://www.eileenslounge.com/viewtopic.php?p=269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fetching-data-from-notepad-to-excel.44312/#post-264364

Later

See here ( This post https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page30#post13349 )
for typical comparisons of text Files, Excel files, and data files
Text File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13693&viewfull=1#post13693
Excel File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13694&viewfull=1#post13694
Data File: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=13695&viewfull=1#post13695

DocAElstein

06-12-2020, 12:52 PM

In support of this thread answer
https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx

' https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx
'XLFlNme is the Excel File name wanted for the new File
'TxtFlNme is Text File name of an existing text file
'valSep is the values separator used in the existing text file
'LineSep is the line separator used in thee existing text file
'Paf it the path to the files. ( I assume they are at the same place for the existing text file and the new Excel File )

Function MakeXLFileusingvaluesInTextFile(ByVal Paf As String, ByVal TxtFlNme As String, ByVal XLFlNme As String, ByVal valSep As String, ByVal LineSep As String)

Rem 2 Text file info
' 2a) get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = Paf & Application.PathSeparator & TxtFlNme ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input...
TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length
Get #FileNum, , TotalFile
Close #FileNum
' 2b) Split into wholes line _ splitting the text file into rows by splitting by Line Seperator
Dim arrRws() As String: Let arrRws() = Split(TotalFile, LineSep, -1, vbBinaryCompare)
Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc...
' 2c) split first line to determine the Field(column) number
Dim arrClms() As String: Let arrClms() = Split(arrRws(0), valSep, -1, vbBinaryCompare)
Dim ClmCnt As Long: Let ClmCnt = UBound(arrClms()) + 1
' 2d) we can now make an array for all the rows, and columns
Dim arrOut() As String: ReDim arrOut(1 To RwCnt, 1 To ClmCnt)

Rem 3 An array is built up by _....
Dim Cnt As Long
For Cnt = 1 To RwCnt ' _.. considering each row of data
'Dim arrClms() As String
Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma
Dim Clm As Long '
For Clm = 1 To UBound(arrClms()) + 1
Let arrOut(Cnt, Clm) = arrClms(Clm - 1)
Next Clm
Next Cnt

Rem 4 Finally the array is pasted to a worksheet in a new file
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Paf & Application.PathSeparator & XLFlNme, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Workbooks("" & XLFlNme & "").Worksheets.Item(1).Range("A1").Resize(RwCnt, ClmCnt).Value = arrOut()

End Function

DocAElstein

06-27-2020, 02:58 PM

In support of the answer to these forum Thread posts
https://www.excelforum.com/excel-programming-vba-macros/1319768-if-condition-met-then-put-the-remark-between-files.html
https://excelfox.com/forum/showthread.php/2433-vba-Copy-Paste-Conditional-to-put-remark-1-2-3-etc?p=14130&viewfull=1#post14130

' https://www.excelforum.com/excel-programming-vba-macros/1319768-if-condition-met-then-put-the-remark-between-files.html#post5353174
Sub karmapala()
'Dim arr() As Variant
Dim Wb1 As Workbook, Wb2 As Workbook, Sh1 As Worksheet, Sh2 As Worksheet
Set Wb1 = Workbooks("1.xls")
Set Sh1 = Wb1.Worksheets.Item(1) ' Wb1.Sheets("1-Sheet1")
Dim Rng As Range ' For main data range in 1.xls
' Set Rng = Sh1.Range("D2", Sh1.Range("D" & Rows.Count).End(xlUp)) ' This and the next line will error if macro.xlsm is active when the macro is run as Rows.Count will give a much larger number ( 1048576 ) than there are rows in a pre Excel 2007 worksheet ( .
' Set Rng = Sh1.Range(Sh1.Range("D2"), Sh1.Range("D" & Rows.Count).End(xlUp))'
Set Rng = Sh1.Range("D2", Sh1.Range("D" & Sh1.Rows.Count).End(xlUp))
Set Wb2 = Workbooks("macro.xlsm") ' Workbooks("Macro.xlsm")
Set Sh2 = Wb2.Worksheets.Item(1) ' Wb2.Sheets("Sheet1")
Dim X As Long
X = 0
Rem 2 In this section we build an array, arr(), of column I values to be ... match Column I of 1.xls with column B of macro.xlsm
Dim Cel As Range
For Each Cel In Rng
Dim arr() As Variant ' This will become the array of column I values to be ... match Column I of 1.xls with column B of macro.xlsm
If Cel.Value = Cel.Offset(0, 1).Value And Cel.Value <> Cel.Offset(0, 2).Value Then
' If column D of 1.xls is equal to Column E of 1.xls & column D of 1.xls is not equal to column F of 1.xls Then ...
ReDim Preserve arr(X)
arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm
X = X + 1 ' to make the array element for the next entry, should there be one
End If

'If Cel.Value <> Cel.Offset(0, 1) And Cel.Value = Cel.Offset(0, 2) Then
If Cel.Value = Cel.Offset(0, 2) And Cel.Value <> Cel.Offset(0, 1) Then ' ...
ReDim Preserve arr(X)
ReDim Preserve arr(X)
arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm
X = X + 1 ' to make the array element for the next entry, should there be one
End If
Next

If X = 0 Then Exit Sub

Rem 3 In this section we take each of the values in column I of 1.xls meeting the criteria - ... match Column I of 1.xls with column B of macro.xlsm
Dim El
For Each El In arr() ' arr take each value in column I meeting the criteria - and look for the match in a row in column B of macro.xlsm
Dim B As Range ' The matched cell in column B in macro.xlsm
Set B = Sh2.Range("B:B").Find(El, lookat:=xlWhole) ' Look for the matched cell in macro.xlsm
If Not B Is Nothing Then
Dim FirstAddress As String: FirstAddress = B.Address ' The first match address to check when the VBA .Find Methos starts again
Do
If B.Offset(0, 1).Value = "" Then
B.Offset(0, 1).Value = 1 ' row of match has remark 1 in column C
Else
B.End(xlToRight).Offset(0, 1).Value = B.End(xlToRight).Value + 1
End If
Set B = Sh2.Range("B:B").FindNext(B) ' Look for the Next matched cell in macro.xlsm
Loop While B.Address <> FirstAddress ' check when the VBA .Find Methos starts again
End If
Next

End Sub

DocAElstein

06-28-2020, 02:37 AM

post to get the URL - for later use

DocAElstein

07-03-2020, 02:47 PM

Solution1 fo this Thread
http://www.eileenslounge.com/viewtopic.php?p=270792#p270792

Sub VBAArrayTypeAlternativeToFilterInSegs_Solution1() ' http://www.eileenslounge.com/viewtopic.php?p=270915#p270915 .......... https://eileenslounge.com/viewtopic.php?p=245238#p245238
Rem Make the two row indicie lists ( string of row indicies seperated witha space )
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Debug.Print strSuc
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1 ': Debug.Print strRws(Cnt - 1)
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
Let Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
' ================================================== ===
Rem Part B)
' Header
Worksheets("TempSht").Range("A7:X7").Copy
Worksheets("consultant doctor").Range("A7:X7").PasteSpecial Paste:=xlPasteAll ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' All formats in one go for each segmant from the temporary blue print worksheet
Worksheets("TempSht").Range("A8:X41").Copy
Worksheets("consultant doctor").Range("A8:X" & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 & "").PasteSpecial Paste:=xlPasteFormats '
' Formulas
Worksheets("TempSht").Range("A35:X41").Copy
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).PasteSpecial Paste:=xlFormulas ' Value = Worksheets("TempSht").Range("A35:X41").Formula
' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard
Next Cnt
' Sorting
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False
Next Cnt

'With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
'' Let .Value = arrOut()
'.Sort key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
'.Font.Name = "Times New Roman"
'.Font.Size = 13
'.Columns("D:X").NumberFormat = "0.00"
'.EntireColumn.AutoFit
'End With

''Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
' Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
' For Cnt = 1 To UBound(strRws(), 1) + 1
' Let Rws(Cnt, 1) = strRws(Cnt - 1)
' Next Cnt
' Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
'With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
'Let .Value = arrOut()
''.Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
'.Font.Name = "Times New Roman"
'.Font.Size = 13
'.Columns("D:X").NumberFormat = "0.00"
'.EntireColumn.AutoFit
'End With
End Sub

DocAElstein

07-03-2020, 03:16 PM

post to get the URL - for later use

DocAElstein

07-05-2020, 05:07 PM

Solution for this post:
https://eileenslounge.com/viewtopic.php?p=271047#p271047
https://eileenslounge.com/viewtopic.php?p=271137#p271137

The main thing is
Sub DropItIn()

The first macro, Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() , which is the one that you run, is almost identical to the very first unmodified macro, Sub VBAArrayTypeAlternativeToFilter() ' https://eileenslounge.com/viewtopic.php?p=270792#p270792

Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() ' https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
' First output worksheet
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
Let .Value = arrOut()
.Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
' Adding extra rows and stuff for Worksheets("consultant doctor") ================
' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
Call DropItIn(Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
' second output worksheet
'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
Let .Value = arrOut()
.Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
' Adding extra rows and stuff for Worksheets("Specialist Doctor") ==================
' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
Call DropItIn(Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted

End Sub

DocAElstein

07-05-2020, 09:39 PM

Macros for Solution 3 in this Thread here
https://eileenslounge.com/viewtopic.php?f=30&t=34878
Post
https://eileenslounge.com/viewtopic.php?p=271150#p271150

Sub Solution3_2Workbooks() '
Rem 1 Worksheets info
Dim WbM As Workbook, WbData As Workbook
Set WbM = ThisWorkbook: Set WbData = Workbooks("Example.xlsx")
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = WbData.Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
' First output worksheet
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
With WbData.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
Let .Value = arrOut()
.Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
' Adding extra rows and stuff for Worksheets("consultant doctor") ================
' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
Call DropItIn3(WbData.Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
' second output worksheet
'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
With WbData.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
Let .Value = arrOut()
.Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
.Borders.LineStyle = xlContinuous
End With
' Adding extra rows and stuff for Worksheets("Specialist Doctor") ==================
' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
Call DropItIn3(WbData.Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted

End Sub

' Call ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
'Worksheets("consultant doctor"), UBound(strRws(), 1) + 1 , 8 , 34 27, 7
' 88 , 8 , 34 , 27 , 7
Sub DropItIn3(Ws As Worksheet, RwsCnt As Long, SttRw As Long, FstBkRw As Long, DtaRws As Long, ExtRws As Long) ' https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047
' Header
ThisWorkbook.Worksheets("TempSht").Range("A7:X7").Copy
Ws.Range("A" & SttRw - 1 & ":X" & SttRw - 1 & "").PasteSpecial Paste:=xlPasteFormats ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' Insert extra rows
' Worksheets("TempSht").Range("A35:X41").Copy
Dim Cnt As Long
' For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) - (DtaRws + ExtRws) Step DtaRws + ExtRws ' This misses the last section
For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) Step DtaRws + ExtRws
ThisWorkbook.Worksheets("TempSht").Range("A35:X41").Copy
Ws.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Insert shift:=xlShiftDown ' Value = Worksheets("TempSht").Range("A35:X41").Formula
' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard
Next Cnt

End Sub

DocAElstein

07-06-2020, 02:31 AM

Macro for solution 4 for this Thread here
https://eileenslounge.com/viewtopic.php?f=30&t=34878
Post
https://eileenslounge.com/viewtopic.php?p=271181&sid=2753bfc8a84fd45abec5487d975c9974#p271181

Sub VBAArrayTypeAlternativeToFilterSolution4() ' BY M. Doc.AElstein .......... https://eileenslounge.com/viewtopic.php?p=245238#p245238
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
Debug.Print strSuc
' First output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), Clms())
Let Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
Rem Part B)
' Header
Worksheets("TempSht").Range("A7:X7").Copy
Worksheets("consultant doctor").Range("A7:X7").PasteSpecial Paste:=xlPasteAll ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' All formats in one go for each segmant from the temporary blue print worksheet
Worksheets("TempSht").Range("A8:X41").Copy
Worksheets("consultant doctor").Range("A8:X" & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 & "").PasteSpecial Paste:=xlPasteFormats '
' Formulas
Worksheets("TempSht").Range("A35:X41").Copy
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).PasteSpecial Paste:=xlFormulas ' Value = Worksheets("TempSht").Range("A35:X41").Formula
' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard
Next Cnt
''' Sorting NO LONGER NEEDED
'' For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
'' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False
'' Next Cnt

' With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
' Let .Value = arrOut()
' .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
' .Font.Name = "Times New Roman"
' .Font.Size = 13
' .Columns("D:X").NumberFormat = "0.00"
' .EntireColumn.AutoFit
' End With
'' second output worksheet
''Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
' For Cnt = 1 To UBound(strRws(), 1) + 1
' Let Rws(Cnt, 1) = strRws(Cnt - 1)
' Next Cnt
' Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), Clms())
' With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
' Let .Value = arrOut()
' .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
' .Font.Name = "Times New Roman"
' .Font.Size = 13
' .Columns("D:X").NumberFormat = "0.00"
' .EntireColumn.AutoFit
' End With
End Sub

DocAElstein

07-07-2020, 11:56 AM

Notes in support of this Thread
https://excelfox.com/forum/showthread.php/2569-Copy-row-from-one-workbook-to-another-workbook-based-on-conditions-in-two-other-workbooks

_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHI
1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTP

2NSEADANIENTEQ151.85165.45151.4151.85152.3525

3NSEAMARAJABATEQ662.5665.9642.55662.5643.5100
Worksheet: 1-Sheet1 6July

_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZ
1UserIdAccountIdEntityNameExchg-SegSymbolInstrument NameOption TypeNetBuyValueNetSellValueNetValueNetBuyQtyNetSel lQtyNetQtyBEPSellAvgPriceBuyAvgPriceLastTradedPric eMarkToMarketRealized MarkToMarketUnrealized MarkToMarketEL MarkToMarketTrading SymbolClient ContextSeries/ExpiryStrike Price

2WC5758NSEAMBUJACEMEQ 10781.1010878.3097.205454201.45199.6520197.297.297 .2AMBUJACEM-EQEQ

3WC5758NSEADANIENTEQ 420.60430.509.9022215.25210.30210.359.99.99.9ADANI ENT-EQEQ25

4WC5758NSESIEMENSEQ 2609.302642.5033.20221321.251304.651322.733.233.23 3.2SIEMENS-EQEQ

5WC5758NSERBLBANKEQ 502.10530.3028.2022265.15251.05249.7528.228.228.2R BLBANK-EQEQ

6WC5758NSENATIONALUMEQ 1768.501782.0013.50545433.0032.7532.7513.513.513.5 NATIONALUM-EQEQ

7WC5758NSEMARICOEQ 1688.401713.0024.6066285.50281.40281.924.624.624.6 MARICO-EQEQ

8WC5758NSEAMARAJABATEQ 2429.102405.70-23.4018133.65134.95135-23.4-23.4-23.4APOLLOTYRE-EQEQ100

9WC5758NSEL&TFHEQ 1765.801794.6028.80181899.7098.1098.2528.828.828.8 L&TFH-EQEQ

10WC5758NSEITCEQ 360.90366.105.2022183.05180.45180.855.25.25.2ITC-EQEQ

11WC5758NSEINFRATELEQ 10988.0011180.70192.705454207.05203.48203.8192.719 2.7192.7INFRATEL-EQEQ

12WC5758NSEDLFEQ 93069.0094283.001214.00486486194.00191.50190.31214 12141214DLF-EQEQ
Worksheet: ap-Sheet1 6July

If column I of 1.xls matches with column Z of ap.xls & column K of ap.xls is equals to column L of ap.xls Then
Look column H of 1.xls & if column H of 1.xls is greater than column D of 1.xls then it has to copy the first row of OrderFormat.xlsx & paste it to BasketOrder.xlsx
If column I of 1.xls matches with column Z of ap.xls & column K of ap.xls is equals to column L of ap.xls Then
Look column H of 1.xls & if column H of 1.xls is lower than column D of 1.xls then it has to copy the third row of OrderFormat.xlsx & paste it to BasketOrder.xlsx

_____ Workbook: OrderFormat.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTU
1NSEEQNANANA00BUYMARKETNACLIMISDAYWC5758NA3NA

2NSEEQNANANA00SELLSL-MCLIMISDAYWC5758NANANA

3NSEEQNANANA00SELLMARKETNACLIMISDAYWC5758NA3NA

4NSEEQNANANA00BUYSL-MCLIMISDAYWC5758NANANA
Worksheet: Sheet1

Given BasketOrder
_____ Workbook: BasketOrder.xlsx Given by Avinash ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O
P
Q
R
S
T
U

1NSEEQNANANA
0
0BUYMARKETNACLIMISDAYWC5758NA
3NA
Worksheet: Sheet1 6July

For I of 25 in row 2 of 1.xls, we match with column z / row 3 in ap.xls
Column K and column L in ap.xls are both = 2 in row 3 in ap.xls So column K of ap.xls is equals to column L of ap.xls
Column H of row 2 in 1.xls is greater than column D of row 2 of 1.xls , so we copy the first row of of OrderFormat.xlsx & paste it to BasketOrder.xlsx
So I assume / geuss the given workbook, BasketOrder.xlsx is for After

DocAElstein

07-07-2020, 12:25 PM

Macro solution for this post:
https://excelfox.com/forum/showthread.php/2569-Copy-row-from-one-workbook-to-another-workbook-based-on-conditions-in-two-other-workbooks

' https://excelfox.com/forum/showthread.php/2569-Copy-row-from-one-workbook-to-another-workbook-based-on-conditions-in-two-other-workbooks
' Copy row from one workbook to another workbook based on conditions in two other workbooks
Sub CopyRowFromWb4ToWb3basedOnConditionsInWb1AndWb2()
Rem 1 worksheets range info
Dim Wb1 As Workbook, Wb2 As Workbook, Wb3 As Workbook, Wb4 As Workbook
Set Wb1 = Workbooks("1.xls")
Set Wb2 = Workbooks("ap.xls")
Set Wb3 = Workbooks("BasketOrder.xlsx")
Set Wb4 = Workbooks("OrderFormat.xlsx")
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet
Set Ws1 = Wb1.Worksheets.Item(1)
Set Ws2 = Wb2.Worksheets.Item(1)
Set Ws3 = Wb3.Worksheets.Item(1)
Set Ws4 = Wb4.Worksheets.Item(1)
Dim Lr1 As Long, Lr2 As Long, Lr3 As Long ', Lr4 As Long
Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Let Lr2 = Ws2.Range("D" & Ws2.Rows.Count & "").End(xlUp).Row
Dim Rng1 As Range, Rng2 As Range ', Rng3 As Range, Rng4 As Range
Set Rng1 = Ws1.Range("A1:I" & Lr1 & "")
Set Rng2 = Ws2.Range("A1:Z" & Lr2 & "")
'1b) data ranges for conditions
Dim arr1() As Variant: Let arr1() = Rng1.Value2
Dim arr1I() As Variant: Let arr1I() = Rng1.Columns(9).Value2
Dim arr2() As Variant: Let arr2() = Rng2.Value2
Dim arr2Z() As Variant: Let arr2Z() = Rng2.Columns("Z").Value2
Rem 2 Do it
Dim Cnt
For Cnt = 2 To Lr1 Step 1
If arr1I(Cnt, 1) <> "" Then
Dim MtchRes As Variant
Let MtchRes = Application.Match(arr1I(Cnt, 1), arr2Z(), 0)
If IsError(MtchRes) Then
' column I 1.xls value is not in column Z of ap.xls
Else ' column I of 1.xls matches with column Z of ap.xls
' if column K of ap.xls is equals to column L of ap.xls
If arr2(MtchRes, 11) = arr2(MtchRes, 12) Then
' If column H of 1.xls is greater than column D of 1.xls then
If arr1(Cnt, 8) > arr1(Cnt, 4) Then
'copy the first row of OrderFormat.xlsx & paste it to BasketOrder.xlsx
Let Ws3.Range("A1:U1").Value2 = Ws4.Range("A1:U1").Value2
ElseIf arr1(Cnt, 8) < arr1(Cnt, 4) Then ' If column H of 1.xls is less than column D of 1.xls then
'copy the third row of OrderFormat.xlsx & pate it to BasketOrder.xlsx
Else
Let Ws3.Range("A1:U1").Value2 = Ws4.Range("A3:U3").Value2
End If
Else
' column K of ap.xls is not equal to column L of ap.xls
End If
End If
Else
' empty column I in 1.xls
End If
Next Cnt
End Sub

DocAElstein

07-07-2020, 04:46 PM

Macro for this post
https://eileenslounge.com/viewtopic.php?f=30&t=34878&p=271237#p271237
https://eileenslounge.com/viewtopic.php?p=271255#p271255

' https://eileenslounge.com/viewtopic.php?f=30&t=34878&p=271237#p271237
Sub Solution5() ' https://eileenslounge.com/viewtopic.php?f=30&t=34878&p=271237#p271237
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
' First half ##
' First output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(27, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
Next Cnt

' First half##
' Second output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(27, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
Next Cnt

End Sub

DocAElstein

07-11-2020, 12:27 AM

Noptes in support of answer for this Post:
https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591

_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTPWrong results

2NSEACCEQ
1265
1282.7
1246.5
1275.3
1247
22BUY
202<--Ws1

3NSEADANIENTEQ
151.85
165.45
151.4
151.85
152.35
25BUY
303

4NSEADANIPORTSEQ
348
348
338.5
346.55
338.85
15083BUY
0

5

6output wanted in K of 1.xls which is Ws1DEFGHIJKL

7
1ExchangeSymbolSeries/ExpiryOpenHighLow Prev CloseLTPwanted results

8
2NSEACCEQ
1265
1282.7
1246.5
1275.3
1247
22BUY
101

9
3NSEADANIENTEQ
151.85
165.45
151.4
151.85
152.35
25BUY
202

10
4NSEADANIPORTSEQ
348
348
338.5
346.55
338.85
15083BUY
303

11
5

12

13

14

15Ws2 - AlertCodes.xlsxBCDEFGHIJKL

16
1NSE
22
6<
100AGTT

17
2NSE
25
6<
200AGTT

18
3NSE
15083
6<
300AGTT

19
4
Worksheet: 1-Sheet1 13July

DocAElstein

07-15-2020, 01:54 PM

Macro for last post, and also for anser to this Thread post:
https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578
https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591
https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html
https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14588&viewfull=1#post14588
https://eileenslounge.com/viewtopic.php?f=30&t=34936

' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks/page4#post14578 https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578
' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591
Sub STEP6()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim Wb1 As Workbook, Wb2 As Workbook
Dim R2 As Long, Lr As Long, I As Long ' r2&, lr&, i&

Set Wb1 = Workbooks("1.xls") ' For open workbook Alternatively to open worknok - Examples: Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Set Wb2 = Workbooks("AlertCodes.xlsx") ' Workbooks.Open(ThisWorkbook.Path & "\AlertCodes.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Files\AlertCodes.xl sx")
Set Ws2 = Wb2.Worksheets.Item(4)
With Ws1
Let Lr = .Cells(.Rows.Count, "A").End(xlUp).Row
For I = 2 To Lr
' Reset r2
R2 = 0
' Avoid error messages
On Error Resume Next
' Try to get r2
R2 = WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0) ' R2 returns the matched row if there is a match
' Restore error handling
On Error GoTo 0
' Only set column K if r2 is valid
If R2 > 0 Then
If Ws2.Cells(R2, "D") = ">" Then
.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value ' Ws2.Cells(I, "E").Value - 0.01 * Ws2.Cells(I, "E").Value
Else
.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value + 0.01 * Ws2.Cells(R2, "E").Value ' Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value
End If
End If
Next I
End With
Wb1.Save
Wb1.Close
Wb2.Close

End Sub

DocAElstein

07-16-2020, 12:18 PM

test post to get URL for later use

DocAElstein

07-16-2020, 01:48 PM

Alternative solution to Step6()
( https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14595&viewfull=1#post14595
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14594&viewfull=1#post14594 )

The main changes are
_1) I use arrays. ( arr1() , arr2() , arr2B() )
I do this just from personal choice. I do this because arrays work much faster if you are only interested in values with no cell formatting
_2) I changed WorksheetFunction.Match to Application.Match , because I do not like to use On Error Resume Next
I do not need On Error Resume Next for Application.Match , because , if it does not find a match, it does not error. Instead, it returns a VBA error string message, which can be tested for using IsError( __ )
_2) I do not use _ With _ End With _ because it confuses me

I left the original code lines in , ' commented out for comparison

' https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html#post5342720 https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html#post5342598
' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks/page4#post14578 https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578
' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591
Sub STEP6Alternative()
Rem 1 Worksheets data info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Dim I As Long, Lr As Long ' R2 As Long, Lr As Long, I As Long ' r2&, lr&, i&
Set Wb1 = Workbooks("1.xls") ' For open workbook Alternatively to open workbook - Examples: Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Set Wb2 = Workbooks("AlertCodes.xlsx") ' Workbooks.Open(ThisWorkbook.Path & "\AlertCodes.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Files\AlertCodes.xl sx")
Set Ws2 = Wb2.Worksheets.Item(4)
' With Ws1
Let Lr = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
Dim arr1() As Variant
Let arr1() = Ws1.Range("A1:K" & Lr & "").Value2
Dim lr2 As Long ' https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=14565&viewfull=1#post14565 Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Let lr2 = Ws2.Cells(Ws2.Rows.Count, "B").End(xlUp).Row ' This is the column to be serached in
Dim arr2B() As Variant
Let arr2B() = Ws2.Range("B1:B" & lr2 & "").Value2
Dim arr2() As Variant
Let arr2() = Ws2.Range("A1:K" & lr2 & "").Value2
Rem We consider the data values in column I of 1.xls ( first worksheet) , starting from row 2.
For I = 2 To Lr ' We consider the data values in column I of 1.xls ( first worksheet) , starting from row 2.
' Reset r2 R2 = 0 ' Avoid error messages On Error Resume Next
' Try to get r2 Values in column I of 1.xls ( first worksheet), starting at row 2, are to be looked for, ( Matched ) in column B of AlertCodes.xlsx ( 4th worksheet )
'R2 = WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0) ' R2 returns the matched row if there is a match
Dim R2 As Variant ' We need a variant so that both a Long Number or a VB error can be held in it, which are the two possible return types with Application.Match https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14204&viewfull=1#post14204
Let R2 = Application.Match(arr1(I, 9), arr2B(), 0) ' Ws1.Cells(I, "I").Value is arr1(I, 9) ' Restore error handling On Error GoTo 0
' Only set column K if r2 is valid, so only if a match was found, so only if R" is Not a VBA error
If Not IsError(R2) Then ' If R2 > 0 Then
'If Ws2.Cells(R2, "D") = ">" Then ' Ws2.Cells(R2, "D").Value is arr2(R2, 4)
If arr2(R2, 4) = ">" Then
' Ws1.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value ' This was wrong: Ws2.Cells(I, "E").Value - 0.01 * Ws2.Cells(I, "E").Value
arr1(I, 11) = arr2(R2, 5) - 0.01 * arr2(R2, 5)
'Else
ElseIf arr2(R2, 4) = "<" Then
' Ws1.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value + 0.01 * Ws2.Cells(R2, "E").Value ' This was wrong: Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value
arr1(I, 11) = arr2(R2, 5) + 0.01 * arr2(R2, 5)
Else
' we dont have a "<" or a ">" Do Nothing
End If
End If
Next I
' End With
'Rem Option to save and/ or close files
Wb1.Save
Wb1.Close
Wb2.Close
End Sub

DocAElstein

07-24-2020, 01:59 PM

Full macro versions for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic.php?p=271960#p271960

Sub Ha2a() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row ' Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2 ' The only data needed to ba considered is column A. The "magic code line" will be used to get all our results in one go I need +1 to use an empty line in determining when the last name in the list has something different after it ##
Rem 2 Outer loop Do ing While data is still there in column A
Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A
Do ' ================================================== ======== Main Outel loop for unique name section==
Rem 3 Inner Loop for a section of names ' ---------------------------------------------------------------
Dim strRws As String: Let strRws = "1" ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed
Do
'3a) get the row indicies for this section
Let CntIn = CntIn + 1
Let strRws = strRws & " " & CntIn
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section ---
'3b) start doing stuff for each unique name
'3b(i) The workbook with unique name
Workbooks.Add
Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)
'3b(ii) The "vertical" array of row indicies required for "magic code line"
Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made
Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the ReDim method below allows us to make the sizing dynamic based on the size of Rws()
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The +1 comes in because the Split function returns a 1D array starting at indicia 0
Dim Cnt As Long
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
'3b(iii) The "magic code line"
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation
'3b(iv) Output to first worksheet in workbook and close and save it
Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
Workbooks(WbNme).Close Savechanges:=True
'3b(v) Some tidying up before we possibly go to the next unique name
Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name
Loop While CntIn < Lr
' ================================================== ================================================== ===

End Sub
' Simplified version
Sub Ha2a_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2
Dim CntIn As Long: Let CntIn = 1
Do
Dim strRws As String: Let strRws = "1"
Do
Let CntIn = CntIn + 1
Let strRws = strRws & " " & CntIn
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1)
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx"
Dim Rws() As String: Let Rws() = Split(strRws)
Dim RwsT() As String
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1)
Dim Cnt As Long
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
Let Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True
Let strRws = "1"
Loop While CntIn < Lr
End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic.php?p=245238#p245238

Ref

DocAElstein

07-24-2020, 03:12 PM

Full macro version for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic.php?p=271960#p271960

Sub Ha2b() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left
Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row ' Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2 ' The only data needed to ba considered is column A. The "magic code line" will be used to get all our results in one go I need +1 to use an empty line in determining when the last name in the list has something different after it ##
Rem 2 Outer loop Do ing While data is still there in column A
Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A
Dim strTRw As Long: Let strTRw = 2 ' We are wanting to determine the start and stop row of a grouped names section. The first one will be at row 2

Do ' ================================================== ======== Main Outel loop for unique name section==
Rem 3 Inner Loop for a section of names ' ---------------------------------------------------------------
Do
'3a) get the row indicies for this section
Let CntIn = CntIn + 1
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section ---
'3b) start doing stuff for each unique name
'3b(i) The workbook with unique name
Workbooks.Add
Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)
'3b(ii) The "vertical" array of row indicies required for "magic code line"
Dim StpRw As Long: Let StpRw = CntIn ' this is the last row for a group of names
Dim RwsT() As Variant ' I need Variant because the Evaluate(" ") methond below returns its field of values in housed in Variant type elements
Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")")
'3b(iii) The "magic code line"
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation
'3b(iv) Output to first worksheet in workbook and close and save it
'Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' I am missing the Header row so start at top left A2 to leave space for the Header
WsM.Range("A1:C1").Copy ' Header row
Ws.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Workbooks(WbNme).Close Savechanges:=True
'3b(v) Some tidying up before we possibly go to the next unique name
Let strTRw = CntIn + 1 ' I assume the next row is the next name
Loop While CntIn < LrM
' ================================================== ================================================== ===

End Sub
' simplified version
Sub Ha2b_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2
Dim CntIn As Long: Let CntIn = 1
Dim strTRw As Long: Let strTRw = 2
Do
Do
Let CntIn = CntIn + 1
Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1)
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx"
Dim Ws As Worksheet: Set Ws = Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1)
Dim StpRw As Long: Let StpRw = CntIn
Dim RwsT() As Variant
Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")")
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
WsM.Range("A1:C1").Copy
Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True
Let strTRw = CntIn + 1
Loop While CntIn < LrM
End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic.php?p=245238#p245238

Ref

DocAElstein

07-24-2020, 04:21 PM

Full macro versions for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic.php?p=271960#p271960

Sub DaDoRunRonDeDo2() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2
Rem 2 obtain unique values from column A
' 2a) A single string containing the unique names
Dim Cnt As Long
For Cnt = 2 To Lr Step 1
Dim strUnics As String
If InStr(1, strUnics, arrA(Cnt, 1), vbBinaryCompare) = 0 Then
Let strUnics = strUnics & arrA(Cnt, 1) & " "
Else
' we already had that name in the string
End If
Next Cnt
Let strUnics = Left(strUnics, (Len(strUnics) - 1)) ' Take off last space
' 2b) A 1 dimansional array of the unique names
Dim arrUnics() As String: Let arrUnics() = Split(strUnics, " ", -1, vbBinaryCompare)
Rem 3 Do it for each unique name
Dim WbCnt As Long: Let WbCnt = UBound(arrUnics()) + 1 ' +1 is needed because Split function returns an array starting at indicia 0
For WbCnt = 1 To WbCnt ' Main outer Loop ========================================
' 3a) Get our indicies for the rows wanted of our current name
Dim strRws As String: Let strRws = "1" ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed
For Cnt = 2 To Lr Step 1
If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then
Let strRws = strRws & " " & Cnt
Else
' The name is not one of the current name being considered
End If
Next Cnt
'3b) start doing stuff for each unique name
'3b(i) The workbook with unique name
Workbooks.Add
Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx" ' The current last unique name will be the new Workbook name
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)

'3b(ii) The "vertical" array of row indicies required for "magic code line"
Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made
Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the ReDim method below allows us to make the sizing dynamic based on the size of Rws()
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The +1 comes in because the Split function returns a 1D array starting at indicia 0
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
'3b(iii) The "magic code line"
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation
'3b(iv) Output to first worksheet in workbook and close and save it
Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
Workbooks(WbNme).Close Savechanges:=True
'3b(v) Some tidying up before we possibly go to the next unique name
Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name

Next WbCnt ' ================================================== ===================
End Sub

' simplified version
Sub DaDoRunRonDeDo2_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2
Dim Cnt As Long
For Cnt = 2 To Lr Step 1
Dim strUnics As String
If InStr(strUnics, arrA(Cnt, 1)) = 0 Then strUnics = strUnics & arrA(Cnt, 1) & " "
Next Cnt
Dim arrUnics() As String: Let arrUnics() = Split(Trim(strUnics))
Dim WbCnt As Long
For WbCnt = 1 To UBound(arrUnics()) + 1
Dim strRws As String: Let strRws = "1"
For Cnt = 2 To Lr Step 1
If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then strRws = strRws & " " & Cnt
Next Cnt
Workbooks.Add
Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx"
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrUnics(WbCnt - 1) & ".xlsx"
Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare)
Dim RwsT() As String
ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1)
For Cnt = 1 To UBound(Rws()) + 1
Let RwsT(Cnt, 1) = Rws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
Let Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Close Savechanges:=True
Let strRws = "1"
Next WbCnt
End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic.php?p=245238#p245238

DocAElstein

07-26-2020, 11:45 AM

Post for later use
Required to get URL now

DocAElstein

07-26-2020, 11:26 PM

In support of this Thread post
https://www.excelforum.com/excel-programming-vba-macros/1327810-delete-rows-based-on-two-criteria-matching-to-entries-on-another-sheet.html#post5397531

Option Explicit and variable declaration
Hello
You can easily find lots of information on the internet that can explain Option Explicit , ( just a few examples given in the Refs below). But my take on it for you:
The simple answer to your specific question is that its not necessary, its just personal choice.
It’s all related to the issue of declaring variables – its difficult to discuss the issue of Option Explicit without discussing the variable declaration issue: In VBA it is not necessary to declare variables. If you use a variable, without an initial declaration, then it will be created “on the fly” as you use them. Mostly they will then be given the Variant type
What a code line at the top of a code module, of Option Explicit , does, is enable the option of being explicit for variable declaration. In other words, it forces you to declare all your variables: If you have this code line at the top of your code module, but then in any coding don’t declare any variable, you will get a warning error, on attempting to run your macro.

Simple Examples
Lets say you make a simple Typo, and write MyMsg , when you meant MyMsig. The following macro won’t error, but it wont give the answer you may have expected.
Sub Testit()
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/WwnXByf.jpg
There’s nufin there in that Message Box! – Why? – The message box is using variable MyMsg: The variables MyMsig and MyMsg were created “on the fly”, as you used them, but MyMsg has not been used yet. There is no error, but you did not get to be warned of your likely typo of writing MyMsg instead of MyMsig

The next 2 macros would warn you of undeclared variables with a compile error on attempting to run them
Option Explicit
Sub Testit()
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/LlXPOfj.jpg
That last macro did not catch your Typo, but if you corrected that missing declaration for MyMsig, then you would still go on to get the warning of the non declared MyMsg
Option Explicit
Sub Testit()
Dim MyMsig As String
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/D9KsQuG.jpg
In fact, in the last macro you would have had the possibility to notice your mistake whilst writing the code line
MsgBox Prompt:=mymsg , provided that you had written it in lower case:
If you had written it just like that, lowercase, mymsg, - having done that, then mymsg would have stayed lowercase when you moved on to writing the next line. On the other hand, If any variable had been declared using any Uppercase characters, then on writing that variable name in lower case characters, and then moving on to the next line, that previous code line would have been changed automatically by the VB Editor to show the correct variable word, including any capital characters.
So an additional point from that experiment is that, if you do choose to declare your variables, then its worth considering using at least one capital in your variable name, but then going on when writing the variable further in the macro to use just lower case always. The VB Editor should automatically correct all your variables, ( and incidentally also correct any commands you type in lower case ) to their correct form including any upper case characters: So, if something remains lower case when you move on to writing the next code line, then you have an immediate indication that something is probably wrong, ( mostly*** ).
( The automatic capitalisation is not directly related to using Option Explicit, but is related to the issue of declaring variables. The use of Option Explicit is mostly of consideration when considering how you choose to handle your variable usage).

So you have a couple of good reason to choose to use Option Explicit and declare your variables carefully.

But you do not have to use Option Explicit
Most people prefer to declare all variables, and to use Option Explicit
There are some people , amongst them respected professionals who go against the trend, don’t use Option Explicit, and consider the use of declaration only where really needed, for example when working when working with class modules. The reasoning is usually given as to avoid redundancy in coding, keeping coding as efficient as possible.

Its personal choice. Do anyfin ya wanna do :)

Molly

Ref:
http://www.eileenslounge.com/viewtopic.php?p=265556#p265556

http://www.eileenslounge.com/viewtopic.php?f=30&t=2281

*** Unfortunately life is not so simple with Microsoft. A bug can cause the automatic capitalization to fail. If you notice this, for example when known commands stay lowercase, then the only known cure seems to be to restart Excel and/ or your computer.

DocAElstein

08-09-2020, 01:51 PM

In support of this Thread:
http://www.eileenslounge.com/viewtopic.php?p=271368#p271368

For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"

' HPageBreaks.Add
ThisWorkbook.Worksheets("consultant doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")

Next Cnt

Sub Solution6() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"

' HPageBreaks.Add
ThisWorkbook.Worksheets("consultant doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")

Next Cnt

' First half##
' Second stage output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
' Most borders
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 1 & "").Value = "The total"
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
' HPageBreaks.Add
ThisWorkbook.Worksheets("Specialist Doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")
Next Cnt

End Sub

DocAElstein

08-09-2020, 01:52 PM

In support of this Thread:
http://www.eileenslounge.com/viewtopic.php?p=271368#p271368

Sub Solution7() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"

' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")
Next Cnt

' First half##
' Second stage output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt

End Sub

DocAElstein

08-09-2020, 01:57 PM

In support of this Thread:
http://www.eileenslounge.com/viewtopic.php?p=271368#p271368

'Second half worksheet Consultant doctor
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"

' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")
Next Cnt

'Second half worksheet Specialist Doctor
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True

.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt

DocAElstein

08-15-2020, 02:34 AM

In support of this Thread post
http://www.eileenslounge.com/viewtopic.php?p=272989#p272989

Sub Solution8() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc
' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")

Next Cnt

' First half##
' Second stage output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
ThisWorkbook.Worksheets("Specialist Doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt

End Sub

DocAElstein

08-16-2020, 01:53 PM

In support of this Thread post
http://www.eileenslounge.com/viewtopic.php?p=272989#p272989
Part 1 of 3

Sub Solution8b() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7" ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then '/////////
Let strSuc = strSuc & " " & Cnt ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Else
Let strSpit = strSpit & " " & Cnt
End If
Next Cnt
'Debug.Print strSuc

DocAElstein

08-16-2020, 06:04 PM

In support of this Thread post
http://www.eileenslounge.com/viewtopic.php?p=272989#p272989

part 2 of 3

' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")

Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
' I need my array to be like 137 rather than like 109 strRws() is 0 To 108 ,
' 137 is ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1
' Missing is ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' At this point we have all the rows with data and the inbetween inserted rows, but we want to extent the output array enough to have the entire range so that I can also paste out the final words and formulas in it
Dim LstEmptyRws As Long: Let LstEmptyRws = ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
Let strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & LstEmptyRws & ")") ' ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' Stop
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
Dim RwsT() As Variant, ClmsT() As Variant
Let ClmsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 2 3 4 5 6 .....
Let RwsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 1 1 1 1 1 1 .....
Let RwsT() = Application.Index(strRws(), RwsT(), ClmsT())
Dim arrOut() As Variant ' This is the main output, all in one go. But we can put some values into the array before...
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, RwsT(), Clms())
' ... we can put some values (words) and formulas into the array before we paste it out
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' ... we can put some values into the array before...
Let arrOut(Cnt + 1 - 6, 1) = "The total" ' -6 is because we have top right of A7
Let arrOut(Cnt + 7 - 6, 1) = "Previous total"
Dim Cl As Long ' formulas
For Cl = 4 To 24 ' D To X
Let arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
' First signature Second signature third signature Fourth signature Fifth signature
' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Let arrOut(Cnt + 2 - 6, 7) = "Second signature"
Let arrOut(Cnt + 2 - 6, 12) = "Third signature"
Let arrOut(Cnt + 2 - 6, 17) = "Forth signature"
Let arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Next Cnt
' Main paste out of all data and some words and formulas
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Consultant doctor
ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
' .Range("A" & Cnt + 1 & "").Value = "The total"
' .Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")

Next Cnt
' delete last unwanted Previous Total row
ThisWorkbook.Worksheets("consultant doctor").Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete shift:=xlUp ' http://www.eileenslounge.com/viewtopic.php?p=271328#p271328 ....Go back to my first post, and look at my maths logic. In the macro we have ((Segs * 27) + ((Segs - 1) * 7) + 7) This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102 I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )...."
' End first stage worksheet_________________________________________ __________________________________________________

'

DocAElstein

08-16-2020, 06:05 PM

In support of this Thread post
http://www.eileenslounge.com/viewtopic.php?p=272989#p272989

part 3 of 3

'
' First half##
' Second stage output worksheet Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop============================================== =================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' At this point we have all the rows with data and the inbetween inserted rows, but we want to extent the output array enough to have the entire range so that I can also paste out the final words and formulas in it
'Dim LstEmptyRws As Long
Let LstEmptyRws = ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
Let strSpit = strSpit & "" & Evaluate("=REPT("" 1""," & LstEmptyRws & ")") ' ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
For Cnt = 1 To UBound(strRws(), 1) + 1
Let Rws(Cnt, 1) = strRws(Cnt - 1)
Next Cnt
'Dim RwsT() As Variant, ClmsT() As Variant
Let ClmsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 2 3 4 5 6 .....
Let RwsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 1 1 1 1 1 1 .....
Let RwsT() = Application.Index(strRws(), RwsT(), ClmsT())

'Dim arrOut() As Variant
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, RwsT(), Clms())
' ... we can put some values (words) and formulas into the array before we paste it out
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' ... we can put some values into the array before...
Let arrOut(Cnt + 1 - 6, 1) = "The total" ' -6 is because we have top right of A7
Let arrOut(Cnt + 7 - 6, 1) = "Previous total"
'Dim Cl As Long ' formulas
For Cl = 4 To 24 ' D To X
Let arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
' First signature Second signature third signature Fourth signature Fifth signature
' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Let arrOut(Cnt + 2 - 6, 7) = "Second signature"
Let arrOut(Cnt + 2 - 6, 12) = "Third signature"
Let arrOut(Cnt + 2 - 6, 17) = "Forth signature"
Let arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Next Cnt
' Main paste out of all data and some words and formulas
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet Specialist Doctor
ThisWorkbook.Worksheets("Specialist Doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
' .Range("A" & Cnt + 1 & "").Value = "The total"
' .Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt
' delete last unwanted Previous Total row
ThisWorkbook.Worksheets("Specialist Doctor").Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete shift:=xlUp ' http://www.eileenslounge.com/viewtopic.php?p=271328#p271328 ....Go back to my first post, and look at my maths logic. In the macro we have ((Segs * 27) + ((Segs - 1) * 7) + 7) This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102 I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )...."
'
End Sub

DocAElstein

08-16-2020, 06:08 PM

In support of this Post
https://eileenslounge.com/viewtopic.php?p=273285#p273285

Sub Solution9ProObfuscation()
Application.ScreenUpdating = False
Dim arrK() As Variant: arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
Dim strSuc As String, strSpit As String
strSuc = "7": strSpit = "7"
Dim Cnt As Long
For Cnt = 11 To UBound(arrK(), 1)
If arrK(Cnt, 1) = "Positive" Then
strSuc = strSuc & " " & Cnt
Else
strSpit = strSpit & " " & Cnt
End If
Next Cnt
Dim Clms() As Variant: Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: strRws() = Split(strSuc)
Dim strNms() As Variant: strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
Dim rOuter As Long
For rOuter = 2 To UBound(strNms)
Dim rInner As Long
For rInner = rOuter + 1 To UBound(strNms)
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant
varTemp = strNms(rOuter): strNms(rOuter) = strNms(rInner): strNms(rInner) = varTemp
Dim TempRs As String
TempRs = strRws(rOuter - 1): strRws(rOuter - 1) = strRws(rInner - 1): strRws(rInner - 1) = TempRs
Else
End If
Next rInner
Next rOuter
strSuc = Join(strRws(), " ")
Dim Segs As Long: Segs = Int(((Len(strSuc) - Len(Replace(strSuc, " ", ""))) + 1) / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6)
Next Cnt
strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(Split(strSuc)) + 1) & ")"): strRws() = Split(strSuc)
Dim arrOut() As Variant
arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Application.Index(strRws(), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")"), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")), Clms())
With ThisWorkbook.Worksheets("consultant doctor")
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
arrOut(Cnt + 1 - 6, 1) = "The total": arrOut(Cnt + 7 - 6, 1) = "Previous total"
Dim Cl As Long
For Cl = 4 To 24
arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C": arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
arrOut(Cnt + 2 - 6, 2) = "First signature": arrOut(Cnt + 2 - 6, 7) = "Second signature": arrOut(Cnt + 2 - 6, 12) = "Third signature": arrOut(Cnt + 2 - 6, 17) = "Forth signature": arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50: .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
Next Cnt
.Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
With .UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
.Rows("7:7").RowHeight = 50
.Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete
End With
strRws() = Split(strSpit)
strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
For rOuter = 2 To UBound(strNms)
For rInner = rOuter + 1 To UBound(strNms)
If strNms(rOuter) > strNms(rInner) Then
varTemp = strNms(rOuter): strNms(rOuter) = strNms(rInner): strNms(rInner) = varTemp
TempRs = strRws(rOuter - 1): strRws(rOuter - 1) = strRws(rInner - 1): strRws(rInner - 1) = TempRs
Else
End If
Next rInner
Next rOuter
strSpit = Join(strRws(), " ")
Segs = Int(((Len(strSpit) - Len(Replace(strSpit, " ", ""))) + 1) / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6)
Next Cnt
strRws() = Split(strSpit)
strSpit = strSpit & "" & Evaluate("=REPT("" 1""," & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1) & ")")
strRws() = Split(strSpit)
arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Application.Index(strRws(), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")"), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")), Clms())
With ThisWorkbook.Worksheets("Specialist Doctor")
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
arrOut(Cnt + 1 - 6, 1) = "The total": arrOut(Cnt + 7 - 6, 1) = "Previous total"
For Cl = 4 To 24
arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C": arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
arrOut(Cnt + 2 - 6, 2) = "First signature": arrOut(Cnt + 2 - 6, 7) = "Second signature": arrOut(Cnt + 2 - 6, 12) = "Third signature": arrOut(Cnt + 2 - 6, 17) = "Forth signature": arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50: .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
Next Cnt
.Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
With .UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
.Rows("7:7").RowHeight = 50
.Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete
End With
Application.ScreenUpdating = True
End Sub

DocAElstein

09-10-2020, 11:39 AM

In support of these Threads
' https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/
' https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html
https://www.excelforum.com/tips-and-tutorials/758402-vba-working-with-areas-within-2d-arrays.html#post5408376

I am not totally sure what the OP is asking.
Is the OP asking
(i) _ to put values into an existing array where that existing array already has values in it
or
(ii)_ changing the array dimension and positioning of elements in an array
or
(iii)_ maybe its lost in the translation and/ or the OP is not sure him/herself.
The initial answer to (i)_ I think we seem clear about:- It will likely in VBA require a code line for each element to be “moved” from one array to the other , so likely looping will be involved for a multi element array.
The Thread title and OPs first question infers to me converting a 1 D array to a 2 D array, without looping.
If the existing array with values already in it is a dynamic array, then overwriting along with re dimensioning means that those (i)_ and (ii)_ are somewhat merged in meaning anyway.
So I am not totally clear what is going on here, but I think it there is a discussion of generally … …”1 D arrays to 2 D arrays”
So lets say we are talking generally about …”1 D arrays to 2 D arrays” and leave it loosely defined for now and go with that…

Frederick has shown in his second code line that a characteristic of the Transpose function is that if a 1 D array is given to the Transpose function then the transposed array becomes a 2 D array , all be it a quasi “1 column array” ***
Transpose does that, as it does the opposite way converting a single column 2D array to a 1D array.
I think most of us are not quite sure why it has been wired to do that. Some other things seem to default to making a “one row” thing be a 1D array rather than a 2D array, even when the thing it may have been given to work on was a 2D array. ( It does not screw things up to badly when playing with spreadsheets since that transposed in its final 1 D form will be “seen” by Excel as if it was a single row 2 Dimensional array when applied to a spreadsheet range. So usually a “row” becomes a row, if you catch my drift).
We can go the other way. ( If we do that with Rick’s example , we will see a small difference, the 1 D array returned will have indices of 1 2 3 4 5 as opposed to the 0 1 2 3 4 , (since the Split function Rick used returns those starting a base 0 ) . I am not sure why Excel chooses to start a t 1 in this case: Possibly it was just made that way because its more often to do with worksheet/spreadsheet stuff, and we think about rows and columns starting at 1, and something like a row of 1 is a bit stupid. )

Index with arrays as co ordinate arguments
This stuff is worth knowing about:
A further function that can be very helpful in doing this sort of manipulation of arrays without looping is the Index Function. It becomes so useful because it will accept arrays in place of the more conventional single value indices in its second ( row ) and third ( column ) arguments. The evaluation is then done in the conventional Excel way, “along the columns of a row” , then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row , ….etc. Usually VBA will do its best to give out the results in an array dimensioned appropriate for the array dimensions supplied in those second and third arguments, following the conventional “along the columns of a row” , then down to repeat at the next row: along the columns of that row, ………

As example we can do that Transpose code line in this pseudo way

' Index(OneDimensionalArray(), 1 , 1
' 1 2
' 1 3
' 1 4
' 1 5 )
We are doing 5 calculations there, talking each time the first row and consecutive columns, the result coming out in a form that the Excel calculations are done - .. “along the columns of a row” , then down to repeat at the next row… but we only have one column in this case, so that is actually just going down the rows, 5 times. Hence our output is the 90degree transpose of OneDimensionalArray()

That was just one example, but the important point is that you can supply different arrays in the Index second ( “row” ) and third ( “column” ) arguments. So you can pretty well take any1 or 2 D array in the Index first argument, and in one code line, without looping , put all or some of the values from that array in some other order in any other 1 or 2 D array. That could be what the OP was asking for ….
Dim Array1(2, 2) As Integer
Dim Array2(2) As Integer
…………… way to copy the values from Array2 into Array1?
The restriction is that we can’t make use of this to put values into Array1( ) if it already existed. You would have to be in like having
Dim Array1() As Variant
Dim Array2(2) As Integer
-……..
Array1()= Index ( Array2(2) , { _.... } , { _... } )
( Variant is needed in the first declaration as the index chucks its output values housed in Variant types. AFAIK the first argument can be any sort of 1 D or 2 D array, ( or it can be any range object ) )

Another not looping option to assist in a conversion could be to remove rows or columns of a 2 D array with a single code line. Best look at some posts of Rick ( Frederick Rothstein (https://excelfox.com/forum/forumdisplay.php/22-Rick-Rothstein-s-Corner) ‘s ) , stuff for that ( https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array )

One last curiosity , a weird thing I only recently came across. An array of arrays, sometimes refereed as a “jagged array”, is peculiarly treated in some cases by Index as a 2 D array. This gives us some interesting further one liner code line possibilities.
Example, If I had a 1 D array of 1 D arrays, something of this sort of form
{ { “Head1” , 2, 3 } , {“Head3”, 4, 5 } , {“Haed2”, 7, 9} }
then I can convert that, for example, to re ordered in data columns like this

' Head1 , Haed2 , Head3
' 2 , 7 , 4
' 3 , 9 , 5
I can do that using like a Index one code liner pseudo

' Index( Head1 , 2, 3 1 , 3 , 2 1 , 1 , 1
' Head3 , 4, 5 1 , 3 , 2 2 , 2 , 2
' Haed2 , 7, 9 1 , 3 , 2 3 , 3 , 3 )

I put some more details of all I have been saying , in a macro in the uploaded file. Probably its best to step through the macro in Debug mode ( do that by hitting Key F8 after clicking anywhere in the macro )

....to be honest with you I've never seen your type of question asked in 20 years of writing code my lifetime. ....
Hello Adam.
I expect you are referring specifically to the idea of putting existing values from an array into another existing array, although I am not fully clear if the OP wanted that: Possibly the language barrier prevented the OP getting anything out of the links you gave him…. The best thing probably, as Rory asked for, was an example from the OP of what he wanted to do…
Anyway, you probably know all the following, but I thought I’d add it to the Thread, while I am in the mood…
Generally questions along the lines of “1 D array to 2 D array” or visa versa are quite common in Excel VBA. I expect this is because
_ a) a lot of things done “internally” in coding involve 1 D arrays,
but/ and
_ b) a range from a spreadsheet will often likely end up in an array of 2 Dimensions, I think Excel does this so that we can make the distinction what is a row and what is a column.***
So things might not always work as we wanted, for example a problem might occur when a 1 D array appears when a 2 D array was expected/ wanted, and visa versa. To solve the problem a conversion from a 1D to 2D or visa versa might get us out of trouble.
Example: we got a Join function that is something like the reverse of the Split function mentioned in this Thread (https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5402848). Basically you can use it to join the contents of an array into a string. The bummer is that it only accepts a 1 D array. So if I give it a column or row of data to join it will error. You’ll need to change the 2D array got from a spreadsheet single row or a spreadsheet single column to a 1D array for join to work on it. ( One way you can do that is with some of the one liner codings I been talking about – I added a example for you in the uploaded macro ### )

***I suppose a 2 D array does not really have “rows” and “columns”, it simply has 2 dimensions. But Excel conventionally puts a spreadsheet row into the fist dimension, and a spreadsheet column into the second dimension. So after using Excel VBA arrays a lot you often get to think of a 2 D array in terms of like arr(row, column) or in terms of orientation like arr(horizontal, vertical). Its just a convenient frame of reference perception.
A 1 D array has no orientation. I can’t really perceive that unless I have drunk a lot of Jack Daniels, as the world starts spinning around, then it becomes very clear, relatively speaking. I suppose Excel can’t get drunk, and as mentioned, a 1 D array seems to be often regarded as like a 2 D array of first dimension size of 1, or pseudo 1 “row” 2 D array.

Molly

Adam, I have definitely had random occurrences of an error like you mentioned, all be it very rarely. When it has happened , I was pretty damm sure it shouldn’t have happened.
I think we all agree that Activateing and Selecting when dealing with worksheet ranges via VBA is rarely needed and is usually a bad idea as the interaction with a spreadsheet slams the brakes on.

I will usually optimise a macro first, with no Activateing and Selecting , ignoring the odd error of that sort you mentioned.
After that I will often see if I don’t compromise the performance much if I add an occasional code line pair of something like
Worksheet("x").Activate: Worksheet("x").Range("A1").Select
Or, if dealing with multiple open workbooks,
Workbooks("x“).Activate: Worksheet("x").Activate: Worksheet("x").Range("A1").Select
at some strategic points.

A typical point would be just before I start doing things to ranges in Worksheet("x") via VBA. I know those two ( three ) code lines should be unnecessary. But it’s been my experience that they help stop that occasional error.
I have no idea what causes the occasional error when all suggest it should not error. I think possibly Excel has some memories of what was last active. Possibly that can become corrupted, and doing a quick Worksheet("x").Activate: Worksheet("x").Range("A1").Select refreshes it.

One thing that has already been touched on here in the Thread a couple of times, which has caught me out a few times: Selecting a range does not activate the worksheet of the range you select.
If the worksheet is not active and you try to select that range then you will get that error.
But selecting a worksheet does activate that worksheet. (Activateing and Selecting a worksheet do something similar, - I think the main difference being that you can select things, but only activate a thing. I have not explored that much yet… )

…but based on the millions of tests that I ran, it became evident that this line of code automatically made the book active:

wbDrawings.SaveAs (ThisWorkbook.Path & Application.PathSeparator & "temp.csv")
.....I would hazard a guess that that might be version dependent and possibly unreliable, as Rory suggested. That dose not consistently activate the workbook being saved, for me.

Molly

DocAElstein

09-10-2020, 11:43 AM

Some additional notes and extended explanations in support of answer to this Thread
https://eileenslounge.com/viewtopic.php?f=30&t=35303&sid=0c127b1ad1adf77124fc302dc186f01b

The OP has this
_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFG
1Header1Header2Header3Header4Header5Header6Header7

2101H2_1H3_1H4_1H5_1H6_1H7_1

3102H2_2H3_2H4_2H5_2H6_2H7_2

4103H2_3H3_3H4_3H5_3H6_3H7_3

5102H2_4H3_4H4_4H5_4H6_4H7_4

6101H2_5H3_5H4_5H5_5H6_5H7_5

7103H2_6H3_6H4_6H5_6H6_6H7_6

8105H2_7H3_7H4_7H5_7H6_7H7_7

9104H2_8H3_8H4_8H5_8H6_8H7_8
Worksheet: Source

This what the OP wants
_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )
Row\ColCDEF
2MyTargetHeader3Header4Header7

3101H3_1H4_1H7_1

4101H3_5H4_5H7_5

5101

6102H3_2H4_2H7_2

7103H3_3H4_3H7_3

8103H3_6H4_6H7_6

9104H3_8H4_8H7_8

10108

11105H3_7H4_7H7_7
Worksheet: Target

Here again what the OP wants, with explanations:

Expected Result

MyTargetHeader3Header4Header7

101H3_1H4_1H7_1first instance

101H3_5H4_5H7_5second instance

101third instance (there is no third instance so left empty)

102H3_2H4_2H7_2

103H3_3H4_3H7_3

103H3_6H4_6H7_6

104H3_8H4_8H7_8

108left empty as there is no 108 in Source

105H3_7H4_7H7_7

You can see that it comes from the source worksheet:

Header1Header2Header3Header4Header5Header6Header7

101H2_1H3_1H4_1H5_1H6_1H7_1

102H2_2H3_2H4_2H5_2H6_2H7_2

103H2_3H3_3H4_3H5_3H6_3H7_3

102H2_4H3_4H4_4H5_4H6_4H7_4

101H2_5H3_5H4_5H5_5H6_5H7_5

103H2_6H3_6H4_6H5_6H6_6H7_6

105H2_7H3_7H4_7H5_7H6_7H7_7

104H2_8H3_8H4_8H5_8H6_8H7_8

Rem 1
The main start point on my logic is obtaining ( in a dynamic way ) a range ( in an array , arrSrch() , ) that looks like this

Header1Header3Header4Header7

101H3_1H4_1H7_1

102H3_2H4_2H7_2

103H3_3H4_3H7_3

102H3_4H4_4H7_4

101H3_5H4_5H7_5

103H3_6H4_6H7_6

105H3_7H4_7H7_7

104H3_8H4_8H7_8

Note: The array arrSrch() has an extra empty row
https://imgur.com/fKjli8W https://i.imgur.com/fKjli8W.jpg

What we do with that is the subject of Rem 2 , and is explained in the next post (https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14906&viewfull=1#post14906)

DocAElstein

09-10-2020, 12:14 PM

Continued from last post (https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14905&viewfull=1#post14905)

Rem 2
We build up a Main 1D array whose elements are themselves 1 D arrays of the required output rows.
This is done by looping down the target range rows , arTgt() = WsT.Range("C2:C" & LrT & "").Value
At each loop we look for a match of the target range row value in the first column of arrSrch()
We then do the array Split type technique ( https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index ) to get a 1 D array of the required row. That row is added to the Main 1 D array
We then remove that row from arrSrch() ( using a function from Rick Rothstein https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array ).
Then we move on to the next target range row down

Rem 3
Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in Index as a 2D array https://eileenslounge.com/viewtopic.php?p=266691#p266691
For demo purposes, the macro in the next post (https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907) pastes out the result in a spare worksheet range:

' Example paste out CHANGE Top left cell H35 to suit
Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut() ' ** -1 is a bodge to knock off the extra row
End Sub

_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )
Row\ColHIJ
35H3_1H4_1H7_1

36H3_5H4_5H7_5

37

38H3_2H4_2H7_2

39H3_3H4_3H7_3

40H3_6H4_6H7_6

41H3_8H4_8H7_8

42

43H3_7H4_7H7_7
Worksheet: Target

Macro, Sub BrdShlss() , and a couple of required Functions are here:
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907

DocAElstein

09-10-2020, 02:47 PM

Macro for these posts
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14905&viewfull=1#post14905
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14906&viewfull=1#post14906
http://www.eileenslounge.com/viewtopic.php?f=30&t=35303

Option Explicit
Sub BrdShlss() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35303 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907
Rem 1 worksheets data info
Dim WsS As Worksheet, WsT As Worksheet
Set WsS = ThisWorkbook.Worksheets("Source"): Set WsT = ThisWorkbook.Worksheets("Target")
Dim LrS As Long, LrT As Long, LcS As Long, LcT As Long
Let LrS = WsS.Range("A" & WsS.Rows.Count & "").End(xlUp).Row
Let LrT = WsT.Range("C" & WsT.Rows.Count & "").End(xlUp).Row
Let LcS = WsS.Cells(1, WsS.Columns.Count).End(xlToLeft).Column
Let LcT = WsT.Cells(2, WsT.Columns.Count).End(xlToLeft).Column
Dim arSrc() As Variant ', arSrcA() As Variant
Let arSrc() = WsS.Range("A1:" & CLtr(LcS) & LrS + 1 & "").Value ' + 1 is to give us an extra empty row
' Let arSrcA() = WsS.Range("A1:A" & LrS & "").Value
Dim arTgt() As Variant: Let arTgt() = WsT.Range("C2:C" & LrT & "").Value
'1b) determine what columns are needed for our search range, since typically not all are needed
Dim strClms As String: Let strClms = "1"
Dim SrchHd() As Variant: Let SrchHd() = WsT.Range("D2:" & CLtr(LcT) & "2").Value
Dim SrcHd() As Variant: Let SrcHd() = WsS.Range("A1:" & CLtr(LcS) & "1").Value
Dim Cnt As Long
For Cnt = 1 To UBound(SrchHd(), 2)
Dim MtchRes As Long ' Note I assume there is always a match in Headers between sheet ranges, so that I always have a number and not an error string
Let MtchRes = Application.Match(SrchHd(1, Cnt), SrcHd(), 0)
Let strClms = strClms & " " & MtchRes ' add a required column indicie

Next Cnt
' Let strClms = Left(strClms, (Len(strClms) - 1)) ' remove last unwanted space For the given example this gives us "3 4 7"
Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & LrS + 1 & ")") ' + 1 is to give us an extra empty row
Dim arrSrch() As Variant ' This will be the reduced size range we need to search in - it has just the headers required
Let arrSrch() = Application.Index(arSrc(), RwsT(), Split(strClms, " ", -1, vbBinaryCompare)) ' In our example Split(strClms, " ", -1, vbBinaryCompare)) is {1, 3, 4, 7)
' Let Range("H24").Resize(UBound(arrSrch(), 1), UBound(arrSrch(), 2)).Value = arrSrch()
'1c) Get initial row string indicies for current source range
'Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & UBound(arSrc(), 1) & ")") ' Typical "vertical" array of row indices needed in Index(Arr, Rws(), Clms()) type code line
'Dim Rws() As Variant: Let Rws() = Application.Index(RwsT(), Evaluate("=Column(A:" & CLtr(UBound(RwsT, 1)) & ")"), Evaluate("=Column(A:" & CLtr(UBound(RwsT(), 1)) & ")/Column(A:" & CLtr(UBound(RwsT(), 1)) & ")")) ' Transpose the "vertical array to get a 1 Dimenrional "horizontal" array
'Dim strRws As String: Let strRws = " " & Join(Rws(), " ") & " " ' This is a string of our row indicies, and later we will remove some indicies as we go along then work the steps above backwards to get a modified RwsT() to use in Index(Arr, Rws(), Clms()) type code line for a new reduced content search array
Rem 2 Building output array
Dim arrOut() As Variant ' A 1 D array for the 1 D arrays at each match
' 2b) main loop for all rows of MyTarget
For Cnt = 2 To UBound(arTgt(), 1) Step 1
ReDim Preserve arrOut(1 To Cnt - 1)
Dim arSrcA() As Variant: Let arSrcA() = Application.Index(arrSrch(), 0, 1) ' the first column of our current arrSrch() ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
Dim VarMtchres As Variant
Let VarMtchres = Application.Match(arTgt(Cnt, 1), arSrcA(), 0)
If IsError(VarMtchres) Then ' we need to add an empty row which we have as the last row of arrSrch()
Let arrOut(Cnt - 1) = Application.Index(arrSrch(), UBound(arrSrch(), 1), 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
Else
Let arrOut(Cnt - 1) = Application.Index(arrSrch(), VarMtchres, 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
'2b(ii) we must remove the row from the arrSrch()
Let arrSrch() = DeleteArrayRow(arrSrch(), (VarMtchres))
End If
Next Cnt
Rem 3 ' Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in Index as a 2D array https://eileenslounge.com/viewtopic.php?p=266691#p266691
Let arrOut() = Application.Index(arrOut(), RwsT(), Evaluate("=Column(B:" & CLtr(UBound(arrSrch(), 2)) & ")")) ' ** this is actually 1 row too big
' Example paste out CHANGE Top left cell H35 to suit
Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut() ' ** -1 is a bodge to knock off the extra row
End Sub

' https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array
Function DeleteArrayRow(Arr As Variant, RowToDelete As Long) As Variant
Dim Rws As Long, Cols As String
Rws = UBound(Arr) - LBound(Arr)
Cols = "A:" & Split(Columns(UBound(Arr, 2) - LBound(Arr, 2) + 1).Address(, 0), ":")(0)
DeleteArrayRow = Application.Index(Arr, Application.Transpose(Split(Join(Application.Trans pose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(Arr) & ")"))))), Evaluate("COLUMN(" & Cols & ")"))
End Function

' https://excelfox.com/forum/showthread.php/1902-Function-Code-for-getting-Column-Letter-from-Column-Number
Public Function CLtr(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CLtr = Chr(65 + (((lclm - 1) Mod 26))) & CLtr: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

DocAElstein

10-10-2020, 02:18 PM

Some notes in support of these Threads
https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing
https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA

Google Browser Page HTML Source
Typically,
_ the first main section in internet page manipulation codings which try to get things from internet sites, is a code section which gets you a single, very long, text string of something similar to what your browser actually uses to present all you see.
( Google Browser also allows you to see in the browser all that text if you right click and select something like Show Page Source ( or use short cut key combination of Strg+u )
ShowPageSource.JPG PageSource.JPG :
https://imgur.com/UnAs5Le , https://imgur.com/bubFTet
https://i.imgur.com/UnAs5Le.jpg , https://i.imgur.com/bubFTet.jpg )

I am not 100% familiar with all the syntaxes and workings of this first code section, but usually they are similar in such codings, and usually I can get that code section to get the HTML page Source text string, ( and we can add a few extra code lines if we want to put all that text string into a text file , so that we can look at it , and use the simple search facility within a text editor, such as Notepad , to find things in that very long text string )
This first code section will get me that text string for a Google Search of ExcelFox , and it will put it in a text file with the name
GoogleSrchExcelFox.txt

Sub GoogleSearchURL() ' https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA
On Error GoTo Bed
'_1 First section get the long text string of the HTML coding of the internet Page
'_1(i) get the long single text string
With CreateObject("msxml2.xmlhttp")
.Open "GET", "https://www.google.com/search?q=ExcelFox", False ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response.
'No extra info here for type GET
.setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo"
'.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" ' https://www.autohotkey.com/boards/viewtopic.php?t=9554 --- It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers.
.send ' varBody:= ' No extra info for type GET. .send actually makes the request
While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc. The responseText property returns the information requested by the Open method as a text string
End With
'_1(ii) Optional secion to put the text string into a text file , for ease of code developments
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName2 As String
Let PathAndFileName2 = ThisWorkbook.Path & "\" & "GoogleSrchExcelFox" & ".txt" ' CHANGE TO SUIT
Open PathAndFileName2 For Output As #FileNum2 ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum2, PageSrc '
Close #FileNum2

_ The second part of such internet page manipulation coding involve often putting that text into an Object that allows a Object oriented programming type analysis of the web page. That is rather advanced and I personally am not too experienced with that.

What I am proposing is a much simplified approach I used myself successfully a few times. It is so simple, that I guess it may not be reliable permanently, for example, when a small change is made to the source page coding by Google. On the other hand , often major changes make the more advanced coding no longer work.
My solution is probably best only to use if you can understand enough to modify it yourself later when it no longer works. That is why I will explain it in detail here.

Examine the string to find the info you want
My solution does very simple basic string manipulation to pick out what I want.
As example, I do google search for ExcelFox manually and programmatically…_
_ Manually:
https://imgur.com/M16cko3 : https://i.imgur.com/M16cko3.jpg
_ Programmatically :
I run the macro snippet above, and look at the text file produced in a text editor. Then I use the search option to look for ExcelFox
NotepadSearch.JPG , Notepad Search.JPG
https://imgur.com/L9dcXBf , https://imgur.com/K4kl3qk
https://i.imgur.com/L9dcXBf.jpg , https://i.imgur.com/K4kl3qk.jpg
If I compare the results of manually and programmatically, then I can pick out a pattern. ( Note: you must look at all the occurrences of ExcelFox – Some will be as part of a text that you don’t want, but you will see a match between the things shown manually, and the text got programmatically.
Example
My manual search got me this: ExcelFoxManaulGooglesearch.JPG : https://imgur.com/M16cko3
https://i.imgur.com/M16cko3.jpg
Consider the first three main URLs given by the search :
http://www.excelfox.com/forum/forum.php
https://excelfox.com/forum/forumdisplay.php/2-Excel-Help
http://www.hifi-forum.de/bild/excel-fox-700e_737672.html
If I search in the text file, I can pick out those inside a similar text section…

' q=ExcelFox&source=lnms&tbm=nws&sa=X&ved=0ahUKEwjO9 PiFs6jsAhXJzoUKHUj-DwcQ_AUIBygD">NEWS</a></td></tr></tbody></table></div></div><div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=http://www.excelfox.com/forum/forum.php&sa=U&ved=2ahUKEwjO9PiFs6jsAhXJzoUKHUj-DwcQFjAAegQIBxAB&usg=AOvVaw3c8Z4i7W8Ooq7f9a8C3CKw"><span class="CVA68e qXLe6d">Excel,
' <span class="qXLe6d FrIlee"> <span class="fYyStc">Have a question in Excel, Access, Powerpoint, Word or Outlook? Ask http://www.?excelfox.com/forum/forum.php.</span> </span> </div> </div></td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://excelfox.com/forum/forumdisplay.php/2-Excel-Help&sa=U&ved=2ahUKEwjO9PiFs6jsAhXJzoUKHUj-
' Weitere Ergebnisse von excelfox.com</a> </span> </div> </div></td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=http://www.hifi-forum.de/bild/excel-fox-700e_737672.html&sa=U&ved=2ahUKEwjO9PiFs6jsAhXJzoU KHUj-DwcQFjACegQIABAB&usg=AOvVaw1WljIWpaSLwuTcgdbTcLeU"><span class="CV

I now repeat the above experiment for a Google search on Chandoo
Manual search results:
ChandooManaulGooglesearch.JPG : https://imgur.com/eQSDHsz
https://i.imgur.com/eQSDHsz.jpg
Considering again just the first 3 results , we have
https://chandoo.org/
https://www.youtube.com/channel/UC8uU_wruBMHeeRma49dtZKA
https://de.wikipedia.org/wiki/Chandu
Programmatic ( looking through the produced text file to find something similar to the first 3 URLs from the manual search)
( This would be the macro to get the text file from that search : https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14992&viewfull=1#post14992 )

' /table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://chandoo.org/&sa=U&ved=2ahUKEwiFs9-r4KrsAhWNC-wKHSLMBb0QFjACegQICBAB&
' <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://www.youtube.com/channel/UC8uU_wruBMHeeRma49dtZKA&sa=U&ved=2ahUKEwiFs9-r4KrsA
' /td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://de.wikipedia.org/wiki/Chandu&sa=U&ved=2ahUKEwiFs9-r4KrsAhWNC-wKHSLMBb0QFjAEegQIARAB&usg=AOvVaw323MmSfVaurlycQW8 E02XJ"><span class="CVA68e qXLe6d">Chandu – Wikipedia</span> <span class="qXLe6d dX

Solution based on simple string analysis
It appears as if we can easily pick out our required URLs from the text if we look for some of the text appearing just before all the URLs.
We could try for example, class="fuLhoc ZWRArf" href="/url?q=
We know then that the text after is out wanted URL
We can also see that we have consistently the same string after URL, so we know we can look for that in order to know the end of the URL text
The implementation of this is fairly simple VBA string manipulation.

DocAElstein

10-10-2020, 02:18 PM

Some notes in support of these Threads
https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing
https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA

Sub GoogleSearchURL() ' https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA
On Error GoTo Bed
'_1 First section get the long text string of the HTML coding of the internet Page
'_1(i) get the long single text string
With CreateObject("msxml2.xmlhttp")
.Open "GET", "https://www.google.com/search?q=Chandoo", False ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response.
'No extra info here for type GET
.setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo"
'.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" ' https://www.autohotkey.com/boards/viewtopic.php?t=9554 --- It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers.
.send ' varBody:= ' No extra info for type GET. .send actually makes the request
While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option
Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc. The responseText property returns the information requested by the Open method as a text string
End With
'_1(ii) Optional secion to put the text string into a text file , for ease of code developments
Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName2 As String
Let PathAndFileName2 = ThisWorkbook.Path & "\" & "Chandoo" & ".txt" ' CHANGE TO SUIT
Open PathAndFileName2 For Output As #FileNum2 ' CHANGE TO SUIT ' Will be made if not there
Print #FileNum2, PageSrc '
Close #FileNum2
End Sub

DocAElstein

10-14-2020, 12:46 PM

In support of this Thread
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria
and answer
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15046&viewfull=1#post15046

This is what the transpose of SM_T_D1() looks like ( SM_T_D1() is actually pseudo horizontal rather than vertical , as it is a 1D array )
_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

Sales Man Territory Dimension

John New York Tissue

Alfred Washington Soda

John New York Soda

Alfred New York Tissue

Leo Washington Soda

Leo New York Tissue

Maxwell Washington Towel

Here is the equivalent transpose of array, SM_T_D2()
_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

Sales Man Territory Dimension

John New York Tissue

John New York Soda

John New York Paper

John New York Towel

John Washington Tissue

John Washington Soda

John Washington Paper

John Washington Towel

Alfred New York Tissue

Alfred New York Soda

Alfred New York Paper

Alfred New York Towel

Alfred Washington Tissue

Alfred Washington Soda

Alfred Washington Paper

Alfred Washington Towel

Leo New York Tissue

Leo New York Soda

Leo New York Paper

Leo New York Towel

Leo Washington Tissue

Leo Washington Soda

Leo Washington Paper

Leo Washington Towel

Maxwell New York Tissue

Maxwell New York Soda

Maxwell New York Paper

Maxwell New York Towel

Maxwell Washington Tissue

Maxwell Washington Soda

Maxwell Washington Paper

Maxwell Washington Towel

DocAElstein

10-25-2020, 12:27 PM

In support of this answer
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15046&viewfull=1#post15046

Before:
___ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
1Sales ManTerritoryDimension Sales Amt Cost

2JohnNew YorkTissue
1,000.00
200.00

3AlfredWashingtonSoda
2,100.00
700.00

4JohnNew YorkSoda
2,050.00
1,500.00

5AlfredNew YorkTissue
2,000.00
500.00

6LeoWashingtonSoda
200.00
100.00

7LeoNew YorkTissue
3,500.00
1,500.00

8MaxwellWashingtonTowel
1,000.00
800.00
Worksheet: Export1

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
1Sales ManTerritoryDimensionSales AmtCost

2JohnNew YorkTissue

3JohnNew YorkSoda

4JohnNew YorkPaper

5JohnNew YorkTowel

6JohnWashingtonTissue

7JohnWashingtonSoda

8JohnWashingtonPaper

9JohnWashingtonTowel

10AlfredNew YorkTissue

11AlfredNew YorkSoda

12AlfredNew YorkPaper

13AlfredNew YorkTowel

14AlfredWashingtonTissue

15AlfredWashingtonSoda

16AlfredWashingtonPaper

17AlfredWashingtonTowel

18LeoNew YorkTissue

19LeoNew YorkSoda

20LeoNew YorkPaper

21LeoNew YorkTowel

22LeoWashingtonTissue

23LeoWashingtonSoda

24LeoWashingtonPaper

25LeoWashingtonTowel

26MaxwellNew YorkTissue

27MaxwellNew YorkSoda

28MaxwellNew YorkPaper

29MaxwellNew YorkTowel

30MaxwellWashingtonTissue

31MaxwellWashingtonSoda

32MaxwellWashingtonPaper

33MaxwellWashingtonTowel
Worksheet: ResultVBA

DocAElstein

10-25-2020, 03:11 PM

In support of this Thread
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria
and answer
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15046&viewfull=1#post15046

After running Sub Arrays1()

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
1Sales ManTerritoryDimensionSales AmtCost

2JohnNew YorkTissue1000200

3JohnNew YorkSoda20501500

4JohnNew YorkPaper

5JohnNew YorkTowel

6JohnWashingtonTissue

7JohnWashingtonSoda

8JohnWashingtonPaper

9JohnWashingtonTowel

10AlfredNew YorkTissue2000500

11AlfredNew YorkSoda

12AlfredNew YorkPaper

13AlfredNew YorkTowel

14AlfredWashingtonTissue

15AlfredWashingtonSoda2100700

16AlfredWashingtonPaper

17AlfredWashingtonTowel

18LeoNew YorkTissue35001500

19LeoNew YorkSoda

20LeoNew YorkPaper

21LeoNew YorkTowel

22LeoWashingtonTissue

23LeoWashingtonSoda200100

24LeoWashingtonPaper

25LeoWashingtonTowel

26MaxwellNew YorkTissue

27MaxwellNew YorkSoda

28MaxwellNew YorkPaper

29MaxwellNew YorkTowel

30MaxwellWashingtonTissue

31MaxwellWashingtonSoda

32MaxwellWashingtonPaper

33MaxwellWashingtonTowel1000800
Worksheet: ResultVBA

DocAElstein

10-26-2020, 03:33 PM

Some extra clarifying info for this thread
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria
and specifically this post
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15048#post15048

For this range with Helper column

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEF
1Sales ManTerritoryDimensionHelper Column Sales Amt Cost

2JohnNew YorkTissueJohn|New York|Tissue 1,000.00 200.00

3AlfredWashingtonSodaAlfred|Washington|Soda 2,100.00 700.00

4JohnNew YorkSodaJohn|New York|Soda 2,050.00 1,500.00

5AlfredNew YorkTissueAlfred|New York|Tissue 2,000.00 500.00

6LeoWashingtonSodaLeo|Washington|Soda 200.00 100.00

7LeoNew YorkTissueLeo|New York|Tissue 3,500.00 1,500.00

8MaxwellWashingtonTowelMaxwell|Washington|Towel 1,000.00 800.00
Worksheet: Export

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\Col
D

1
Helper Column

2
=A2&"|"&B2&"|"&C2

3
=A3&"|"&B3&"|"&C3

4
=A4&"|"&B4&"|"&C4

5
=A5&"|"&B5&"|"&C5

6
=A6&"|"&B6&"|"&C6

7
=A7&"|"&B7&"|"&C7

8
=A8&"|"&B8&"|"&C8
Worksheet: Export

Formula VLookUp

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IF(ISERROR(VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,2,FALSE)),"",VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,2,FALSE))
=IF(ISERROR(VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,3,FALSE)),"",VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,3,FALSE))
Worksheet: ResultVLookUp

Formula Index

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IF(ISERROR(INDEX(Export!$E$2:$E$8,MATCH(1,(Result Index!A2=Export!$A$2:$A$8)*(ResultIndex!B2=Export! $B$2:$B$8)*(ResultIndex!C2=Export!$C$2:$C$8),0),1) ),"",INDEX(Export!$E$2:$E$8,MATCH(1,(ResultIndex!A2=Ex port!$A$2:$A$8)*(ResultIndex!B2=Export!$B$2:$B$8)* (ResultIndex!C2=Export!$C$2:$C$8),0),1))
=IF(ISERROR(INDEX(Export!$F$2:$F$8,MATCH(1,(Result Index!A2=Export!$A$2:$A$8)*(ResultIndex!B2=Export! $B$2:$B$8)*(ResultIndex!C2=Export!$C$2:$C$8),0),1) ),"",INDEX(Export!$F$2:$F$8,MATCH(1,(ResultIndex!A2=Ex port!$A$2:$A$8)*(ResultIndex!B2=Export!$B$2:$B$8)* (ResultIndex!C2=Export!$C$2:$C$8),0),1))
Worksheet: ResultIndex

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IFERROR(INDEX(Export!$E$2:$E$8,MATCH(1,(ResultInd ex2!A2=Export!$A$2:$A$8)*(ResultIndex2!B2=Export!$ B$2:$B$8)*(ResultIndex2!C2=Export!$C$2:$C$8),0),1) ,"")
=IFERROR(INDEX(Export!$F$2:$F$8,MATCH(1,(ResultInd ex2!A2=Export!$A$2:$A$8)*(ResultIndex2!B2=Export!$ B$2:$B$8)*(ResultIndex2!C2=Export!$C$2:$C$8),0),1) ,"")
Worksheet: ResultIndex2

DocAElstein

10-26-2020, 03:42 PM

Some extra clarifying info for this thread
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria
and specifically this post
https://excelfox.com/forum/showthread.php/2667-VLOOKUP-on-Matching-Multiple-Criteria?p=15048#post15048

For this range

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDE
1Sales ManTerritoryDimension Sales Amt Cost

2JohnNew YorkTissue 1,000.00 200.00

3AlfredWashingtonSoda 2,100.00 700.00

4JohnNew YorkSoda 2,050.00 1,500.00

5AlfredNew YorkTissue 2,000.00 500.00

6LeoWashingtonSoda 200.00 100.00

7LeoNew YorkTissue 3,500.00 1,500.00

8MaxwellWashingtonTowel 1,000.00 800.00
Worksheet: Export1

Index Formulas

From P45cal

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IF(ISERROR(INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0))),"",INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)))
=IF(ISERROR(INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0))),"",INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)))
Worksheet: P45cal

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IFERROR(INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)),"")
=IFERROR(INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)),"")
Worksheet: P45cal1

From Alan ( DocAElstein )

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IF(ISERROR(INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIn dex!A2=Export1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$ 2:$B$8)*(ResIndex!C2=Export1!$C$2:$C$8),0),1)),"",INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIndex!A2=Expo rt1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$2:$B$8)*(Re sIndex!C2=Export1!$C$2:$C$8),0),1))
=IF(ISERROR(INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIn dex!A2=Export1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$ 2:$B$8)*(ResIndex!C2=Export1!$C$2:$C$8),0),1)),"",INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIndex!A2=Expo rt1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$2:$B$8)*(Re sIndex!C2=Export1!$C$2:$C$8),0),1))
Worksheet: ResIndex

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )
Row\Col
D
E

2
=IFERROR(INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIndex 2!A2=Export1!$A$2:$A$8)*(ResIndex2!B2=Export1!$B$2 :$B$8)*(ResIndex2!C2=Export1!$C$2:$C$8),0),1),"")
=IFERROR(INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIndex 2!A2=Export1!$A$2:$A$8)*(ResIndex2!B2=Export1!$B$2 :$B$8)*(ResIndex2!C2=Export1!$C$2:$C$8),0),1),"")
Worksheet: ResIndex2

DocAElstein

11-01-2020, 03:39 PM

In suppot of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35600

' http://www.eileenslounge.com/viewtopic.php?f=30&t=35600
Sub ConvertBytesToString1()
Dim Ay() As Variant: Let Ay() = Array(89, 97, 115, 115, 101, 114)
Dim Es As String
Dim Spt() As String
Let Spt() = Split(ChrW(1) & "Sp" & ChrW(2) & "Sp" & ChrW(3) & "Sp" & ChrW(4) & "Sp" & ChrW(5) & "Sp" & ChrW(6) & "Sp" & ChrW(7) & "Sp" & ChrW(8) & "Sp" & ChrW(9) & "Sp" & ChrW(10) & "Sp" & ChrW(11) & "Sp" & ChrW(12) & "Sp" & ChrW(13) & "Sp" & ChrW(14) & "Sp" & ChrW(15) & "Sp" & ChrW(16) & "Sp" & ChrW(17) & "Sp" & ChrW(18) & "Sp" & ChrW(19) & "Sp" & ChrW(20) & "Sp" & ChrW(21) & "Sp" & ChrW(22) & "Sp" & ChrW(23) & "Sp" & ChrW(24) & "Sp" & ChrW(25) & "Sp" & ChrW(26) & "Sp" & ChrW(27) & "Sp" & ChrW(28) & "Sp" & ChrW(29) & "Sp" & ChrW(30) & "Sp" & ChrW(31) & "Sp" & ChrW(32) & "Sp" & ChrW(33) & "Sp" & ChrW(34) & "Sp" & ChrW(35) & "Sp" & ChrW(36) & "Sp" & ChrW(37) & "Sp" & ChrW(38) & "Sp" & ChrW(39) & "Sp" & ChrW(40) & "Sp" & ChrW(41) & "Sp" & ChrW(42) & "Sp" & ChrW(43) & "Sp" & ChrW(44) & "Sp" & ChrW(45) & "Sp" & ChrW(46) & "Sp" & ChrW(47) & "Sp" & ChrW(48) & "Sp" & ChrW(49) & "Sp" & ChrW(50) & _
"Sp" & ChrW(51) & "Sp" & ChrW(52) & "Sp" & ChrW(53) & "Sp" & ChrW(54) & "Sp" & ChrW(55) & "Sp" & ChrW(56) & "Sp" & ChrW(57) & "Sp" & ChrW(58) & "Sp" & ChrW(59) & "Sp" & ChrW(60) & "Sp" & ChrW(61) & "Sp" & ChrW(62) & "Sp" & ChrW(63) & "Sp" & ChrW(64) & "Sp" & ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126) & "Sp" & ChrW(127) & "Sp" & ChrW(128) & "Sp" & ChrW(129) & "Sp" & ChrW(130) & "Sp" & ChrW(131) & "Sp" & ChrW(132) & "Sp" & ChrW(133) & "Sp" & ChrW(134) & "Sp" & ChrW(135) & "Sp" & ChrW(136) & "Sp" & ChrW(137) & "Sp" & ChrW(138) & "Sp" & ChrW(139) & "Sp" & ChrW(140) & "Sp" & ChrW(141) & "Sp" & ChrW(142) & "Sp" & ChrW(143) & "Sp" & ChrW(144) & "Sp" & ChrW(145) & "Sp" & ChrW(146) & "Sp" & ChrW(147) & "Sp" & ChrW(148) & "Sp" & ChrW(149) & "Sp" & ChrW(150) & _
"Sp" & ChrW(151) & "Sp" & ChrW(152) & "Sp" & ChrW(153) & "Sp" & ChrW(154) & "Sp" & ChrW(155) & "Sp" & ChrW(156) & "Sp" & ChrW(157) & "Sp" & ChrW(158) & "Sp" & ChrW(159) & "Sp" & ChrW(160) & "Sp" & ChrW(161) & "Sp" & ChrW(162) & "Sp" & ChrW(163) & "Sp" & ChrW(164) & "Sp" & ChrW(165) & "Sp" & ChrW(166) & "Sp" & ChrW(167) & "Sp" & ChrW(168) & "Sp" & ChrW(169) & "Sp" & ChrW(170) & "Sp" & ChrW(171) & "Sp" & ChrW(172) & "Sp" & ChrW(173) & "Sp" & ChrW(174) & "Sp" & ChrW(175) & "Sp" & ChrW(176) & "Sp" & ChrW(177) & "Sp" & ChrW(178) & "Sp" & ChrW(179) & "Sp" & ChrW(180) & "Sp" & ChrW(181) & "Sp" & ChrW(182) & "Sp" & ChrW(183) & "Sp" & ChrW(184) & "Sp" & ChrW(185) & "Sp" & ChrW(186) & "Sp" & ChrW(187) & "Sp" & ChrW(188) & "Sp" & ChrW(189) & "Sp" & ChrW(190) & "Sp" & ChrW(191) & "Sp" & ChrW(192) & "Sp" & ChrW(193) & "Sp" & ChrW(194) & "Sp" & ChrW(195) & "Sp" & ChrW(196) & "Sp" & ChrW(197) & "Sp" & ChrW(198) & "Sp" & ChrW(199) & "Sp" & ChrW(200), "Sp")
' Let Range("A2").Resize(1, 200) = Spt()
Let Es = Join(Application.Index(Spt(), 1, Ay), "")
' Or
Let Es = Join(Application.Index(Split(ChrW(1) & "Sp" & ChrW(2) & "Sp" & ChrW(3) & "Sp" & ChrW(4) & "Sp" & ChrW(5) & "Sp" & ChrW(6) & "Sp" & ChrW(7) & "Sp" & ChrW(8) & "Sp" & ChrW(9) & "Sp" & ChrW(10) & "Sp" & ChrW(11) & "Sp" & ChrW(12) & "Sp" & ChrW(13) & "Sp" & ChrW(14) & "Sp" & ChrW(15) & "Sp" & ChrW(16) & "Sp" & ChrW(17) & "Sp" & ChrW(18) & "Sp" & ChrW(19) & "Sp" & ChrW(20) & "Sp" & ChrW(21) & "Sp" & ChrW(22) & "Sp" & ChrW(23) & "Sp" & ChrW(24) & "Sp" & ChrW(25) & "Sp" & ChrW(26) & "Sp" & ChrW(27) & "Sp" & ChrW(28) & "Sp" & ChrW(29) & "Sp" & ChrW(30) & "Sp" & ChrW(31) & "Sp" & ChrW(32) & "Sp" & ChrW(33) & "Sp" & ChrW(34) & "Sp" & ChrW(35) & "Sp" & ChrW(36) & "Sp" & ChrW(37) & "Sp" & ChrW(38) & "Sp" & ChrW(39) & "Sp" & ChrW(40) & "Sp" & ChrW(41) & "Sp" & ChrW(42) & "Sp" & ChrW(43) & "Sp" & ChrW(44) & "Sp" & ChrW(45) & "Sp" & ChrW(46) & "Sp" & ChrW(47) & "Sp" & ChrW(48) & "Sp" & ChrW(49) & "Sp" & ChrW(50) & _
"Sp" & ChrW(51) & "Sp" & ChrW(52) & "Sp" & ChrW(53) & "Sp" & ChrW(54) & "Sp" & ChrW(55) & "Sp" & ChrW(56) & "Sp" & ChrW(57) & "Sp" & ChrW(58) & "Sp" & ChrW(59) & "Sp" & ChrW(60) & "Sp" & ChrW(61) & "Sp" & ChrW(62) & "Sp" & ChrW(63) & "Sp" & ChrW(64) & "Sp" & ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126) & "Sp" & ChrW(127) & "Sp" & ChrW(128) & "Sp" & ChrW(129) & "Sp" & ChrW(130) & "Sp" & ChrW(131) & "Sp" & ChrW(132) & "Sp" & ChrW(133) & "Sp" & ChrW(134) & "Sp" & ChrW(135) & "Sp" & ChrW(136) & "Sp" & ChrW(137) & "Sp" & ChrW(138) & "Sp" & ChrW(139) & "Sp" & ChrW(140) & "Sp" & ChrW(141) & "Sp" & ChrW(142) & "Sp" & ChrW(143) & "Sp" & ChrW(144) & "Sp" & ChrW(145) & "Sp" & ChrW(146) & "Sp" & ChrW(147) & "Sp" & ChrW(148) & "Sp" & ChrW(149) & "Sp" & ChrW(150) & _
"Sp" & ChrW(151) & "Sp" & ChrW(152) & "Sp" & ChrW(153) & "Sp" & ChrW(154) & "Sp" & ChrW(155) & "Sp" & ChrW(156) & "Sp" & ChrW(157) & "Sp" & ChrW(158) & "Sp" & ChrW(159) & "Sp" & ChrW(160) & "Sp" & ChrW(161) & "Sp" & ChrW(162) & "Sp" & ChrW(163) & "Sp" & ChrW(164) & "Sp" & ChrW(165) & "Sp" & ChrW(166) & "Sp" & ChrW(167) & "Sp" & ChrW(168) & "Sp" & ChrW(169) & "Sp" & ChrW(170) & "Sp" & ChrW(171) & "Sp" & ChrW(172) & "Sp" & ChrW(173) & "Sp" & ChrW(174) & "Sp" & ChrW(175) & "Sp" & ChrW(176) & "Sp" & ChrW(177) & "Sp" & ChrW(178) & "Sp" & ChrW(179) & "Sp" & ChrW(180) & "Sp" & ChrW(181) & "Sp" & ChrW(182) & "Sp" & ChrW(183) & "Sp" & ChrW(184) & "Sp" & ChrW(185) & "Sp" & ChrW(186) & "Sp" & ChrW(187) & "Sp" & ChrW(188) & "Sp" & ChrW(189) & "Sp" & ChrW(190) & "Sp" & ChrW(191) & "Sp" & ChrW(192) & "Sp" & ChrW(193) & "Sp" & ChrW(194) & "Sp" & ChrW(195) & "Sp" & ChrW(196) & "Sp" & ChrW(197) & "Sp" & ChrW(198) & "Sp" & ChrW(199) & "Sp" & ChrW(200), "Sp"), 1, Ay), "")
End Sub

DocAElstein

11-01-2020, 03:41 PM

In support of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35600

Sub ConvertBytesToString2()
Dim Es As String
Dim Spt() As String
Let Spt() = Split(ChrW(1) & "Sp" & ChrW(2) & "Sp" & ChrW(3) & "Sp" & ChrW(4) & "Sp" & ChrW(5) & "Sp" & ChrW(6) & "Sp" & ChrW(7) & "Sp" & ChrW(8) & "Sp" & ChrW(9) & "Sp" & ChrW(10) & "Sp" & ChrW(11) & "Sp" & ChrW(12) & "Sp" & ChrW(13) & "Sp" & ChrW(14) & "Sp" & ChrW(15) & "Sp" & ChrW(16) & "Sp" & ChrW(17) & "Sp" & ChrW(18) & "Sp" & ChrW(19) & "Sp" & ChrW(20) & "Sp" & ChrW(21) & "Sp" & ChrW(22) & "Sp" & ChrW(23) & "Sp" & ChrW(24) & "Sp" & ChrW(25) & "Sp" & ChrW(26) & "Sp" & ChrW(27) & "Sp" & ChrW(28) & "Sp" & ChrW(29) & "Sp" & ChrW(30) & "Sp" & ChrW(31) & "Sp" & ChrW(32) & "Sp" & ChrW(33) & "Sp" & ChrW(34) & "Sp" & ChrW(35) & "Sp" & ChrW(36) & "Sp" & ChrW(37) & "Sp" & ChrW(38) & "Sp" & ChrW(39) & "Sp" & ChrW(40) & "Sp" & ChrW(41) & "Sp" & ChrW(42) & "Sp" & ChrW(43) & "Sp" & ChrW(44) & "Sp" & ChrW(45) & "Sp" & ChrW(46) & "Sp" & ChrW(47) & "Sp" & ChrW(48) & "Sp" & ChrW(49) & "Sp" & ChrW(50) & _
"Sp" & ChrW(51) & "Sp" & ChrW(52) & "Sp" & ChrW(53) & "Sp" & ChrW(54) & "Sp" & ChrW(55) & "Sp" & ChrW(56) & "Sp" & ChrW(57) & "Sp" & ChrW(58) & "Sp" & ChrW(59) & "Sp" & ChrW(60) & "Sp" & ChrW(61) & "Sp" & ChrW(62) & "Sp" & ChrW(63) & "Sp" & ChrW(64) & "Sp" & ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126) & "Sp" & ChrW(127) & "Sp" & ChrW(128) & "Sp" & ChrW(129) & "Sp" & ChrW(130) & "Sp" & ChrW(131) & "Sp" & ChrW(132) & "Sp" & ChrW(133) & "Sp" & ChrW(134) & "Sp" & ChrW(135) & "Sp" & ChrW(136) & "Sp" & ChrW(137) & "Sp" & ChrW(138) & "Sp" & ChrW(139) & "Sp" & ChrW(140) & "Sp" & ChrW(141) & "Sp" & ChrW(142) & "Sp" & ChrW(143) & "Sp" & ChrW(144) & "Sp" & ChrW(145) & "Sp" & ChrW(146) & "Sp" & ChrW(147) & "Sp" & ChrW(148) & "Sp" & ChrW(149) & "Sp" & ChrW(150) & _
"Sp" & ChrW(151) & "Sp" & ChrW(152) & "Sp" & ChrW(153) & "Sp" & ChrW(154) & "Sp" & ChrW(155) & "Sp" & ChrW(156) & "Sp" & ChrW(157) & "Sp" & ChrW(158) & "Sp" & ChrW(159) & "Sp" & ChrW(160) & "Sp" & ChrW(161) & "Sp" & ChrW(162) & "Sp" & ChrW(163) & "Sp" & ChrW(164) & "Sp" & ChrW(165) & "Sp" & ChrW(166) & "Sp" & ChrW(167) & "Sp" & ChrW(168) & "Sp" & ChrW(169) & "Sp" & ChrW(170) & "Sp" & ChrW(171) & "Sp" & ChrW(172) & "Sp" & ChrW(173) & "Sp" & ChrW(174) & "Sp" & ChrW(175) & "Sp" & ChrW(176) & "Sp" & ChrW(177) & "Sp" & ChrW(178) & "Sp" & ChrW(179) & "Sp" & ChrW(180) & "Sp" & ChrW(181) & "Sp" & ChrW(182) & "Sp" & ChrW(183) & "Sp" & ChrW(184) & "Sp" & ChrW(185) & "Sp" & ChrW(186) & "Sp" & ChrW(187) & "Sp" & ChrW(188) & "Sp" & ChrW(189) & "Sp" & ChrW(190) & "Sp" & ChrW(191) & "Sp" & ChrW(192) & "Sp" & ChrW(193) & "Sp" & ChrW(194) & "Sp" & ChrW(195) & "Sp" & ChrW(196) & "Sp" & ChrW(197) & "Sp" & ChrW(198) & "Sp" & ChrW(199) & "Sp" & ChrW(200), "Sp")
Let Es = Join(Application.Index(Spt(), 1, Evaluate("={89, 97, 115, 115, 101, 114}")), "")
' Or
Let Es = Join(Application.Index(Split(ChrW(1) & "Sp" & ChrW(2) & "Sp" & ChrW(3) & "Sp" & ChrW(4) & "Sp" & ChrW(5) & "Sp" & ChrW(6) & "Sp" & ChrW(7) & "Sp" & ChrW(8) & "Sp" & ChrW(9) & "Sp" & ChrW(10) & "Sp" & ChrW(11) & "Sp" & ChrW(12) & "Sp" & ChrW(13) & "Sp" & ChrW(14) & "Sp" & ChrW(15) & "Sp" & ChrW(16) & "Sp" & ChrW(17) & "Sp" & ChrW(18) & "Sp" & ChrW(19) & "Sp" & ChrW(20) & "Sp" & ChrW(21) & "Sp" & ChrW(22) & "Sp" & ChrW(23) & "Sp" & ChrW(24) & "Sp" & ChrW(25) & "Sp" & ChrW(26) & "Sp" & ChrW(27) & "Sp" & ChrW(28) & "Sp" & ChrW(29) & "Sp" & ChrW(30) & "Sp" & ChrW(31) & "Sp" & ChrW(32) & "Sp" & ChrW(33) & "Sp" & ChrW(34) & "Sp" & ChrW(35) & "Sp" & ChrW(36) & "Sp" & ChrW(37) & "Sp" & ChrW(38) & "Sp" & ChrW(39) & "Sp" & ChrW(40) & "Sp" & ChrW(41) & "Sp" & ChrW(42) & "Sp" & ChrW(43) & "Sp" & ChrW(44) & "Sp" & ChrW(45) & "Sp" & ChrW(46) & "Sp" & ChrW(47) & "Sp" & ChrW(48) & "Sp" & ChrW(49) & "Sp" & ChrW(50) & _
"Sp" & ChrW(51) & "Sp" & ChrW(52) & "Sp" & ChrW(53) & "Sp" & ChrW(54) & "Sp" & ChrW(55) & "Sp" & ChrW(56) & "Sp" & ChrW(57) & "Sp" & ChrW(58) & "Sp" & ChrW(59) & "Sp" & ChrW(60) & "Sp" & ChrW(61) & "Sp" & ChrW(62) & "Sp" & ChrW(63) & "Sp" & ChrW(64) & "Sp" & ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126) & "Sp" & ChrW(127) & "Sp" & ChrW(128) & "Sp" & ChrW(129) & "Sp" & ChrW(130) & "Sp" & ChrW(131) & "Sp" & ChrW(132) & "Sp" & ChrW(133) & "Sp" & ChrW(134) & "Sp" & ChrW(135) & "Sp" & ChrW(136) & "Sp" & ChrW(137) & "Sp" & ChrW(138) & "Sp" & ChrW(139) & "Sp" & ChrW(140) & "Sp" & ChrW(141) & "Sp" & ChrW(142) & "Sp" & ChrW(143) & "Sp" & ChrW(144) & "Sp" & ChrW(145) & "Sp" & ChrW(146) & "Sp" & ChrW(147) & "Sp" & ChrW(148) & "Sp" & ChrW(149) & "Sp" & ChrW(150) & _
"Sp" & ChrW(151) & "Sp" & ChrW(152) & "Sp" & ChrW(153) & "Sp" & ChrW(154) & "Sp" & ChrW(155) & "Sp" & ChrW(156) & "Sp" & ChrW(157) & "Sp" & ChrW(158) & "Sp" & ChrW(159) & "Sp" & ChrW(160) & "Sp" & ChrW(161) & "Sp" & ChrW(162) & "Sp" & ChrW(163) & "Sp" & ChrW(164) & "Sp" & ChrW(165) & "Sp" & ChrW(166) & "Sp" & ChrW(167) & "Sp" & ChrW(168) & "Sp" & ChrW(169) & "Sp" & ChrW(170) & "Sp" & ChrW(171) & "Sp" & ChrW(172) & "Sp" & ChrW(173) & "Sp" & ChrW(174) & "Sp" & ChrW(175) & "Sp" & ChrW(176) & "Sp" & ChrW(177) & "Sp" & ChrW(178) & "Sp" & ChrW(179) & "Sp" & ChrW(180) & "Sp" & ChrW(181) & "Sp" & ChrW(182) & "Sp" & ChrW(183) & "Sp" & ChrW(184) & "Sp" & ChrW(185) & "Sp" & ChrW(186) & "Sp" & ChrW(187) & "Sp" & ChrW(188) & "Sp" & ChrW(189) & "Sp" & ChrW(190) & "Sp" & ChrW(191) & "Sp" & ChrW(192) & "Sp" & ChrW(193) & "Sp" & ChrW(194) & "Sp" & ChrW(195) & "Sp" & ChrW(196) & "Sp" & ChrW(197) & "Sp" & ChrW(198) & "Sp" & ChrW(199) & "Sp" & ChrW(200), "Sp"), 1, Evaluate("={89, 97, 115, 115, 101, 114}")), "")
End Sub

DocAElstein

11-01-2020, 03:45 PM

In support of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35600

' If I don't need all characters, then I can simplify a bit
Sub ConvertBytesToString3()
Dim Es As String
Dim Spt() As String
Let Spt() = Split(ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126), "Sp")
Let Es = Join(Application.Index(Spt(), 1, Evaluate("={89, 97, 115, 115, 101, 114}-64")), "")
' Or
Let Es = Join(Application.Index(Split(ChrW(65) & "Sp" & ChrW(66) & "Sp" & ChrW(67) & "Sp" & ChrW(68) & "Sp" & ChrW(69) & "Sp" & ChrW(70) & "Sp" & ChrW(71) & "Sp" & ChrW(72) & "Sp" & ChrW(73) & "Sp" & ChrW(74) & "Sp" & ChrW(75) & "Sp" & ChrW(76) & "Sp" & ChrW(77) & "Sp" & ChrW(78) & "Sp" & ChrW(79) & "Sp" & ChrW(80) & "Sp" & ChrW(81) & "Sp" & ChrW(82) & "Sp" & ChrW(83) & "Sp" & ChrW(84) & "Sp" & ChrW(85) & "Sp" & ChrW(86) & "Sp" & ChrW(87) & "Sp" & ChrW(88) & "Sp" & ChrW(89) & "Sp" & ChrW(90) & "Sp" & ChrW(91) & "Sp" & ChrW(92) & "Sp" & ChrW(93) & "Sp" & ChrW(94) & "Sp" & ChrW(95) & "Sp" & ChrW(96) & "Sp" & ChrW(97) & "Sp" & ChrW(98) & "Sp" & ChrW(99) & "Sp" & ChrW(100) & _
"Sp" & ChrW(101) & "Sp" & ChrW(102) & "Sp" & ChrW(103) & "Sp" & ChrW(104) & "Sp" & ChrW(105) & "Sp" & ChrW(106) & "Sp" & ChrW(107) & "Sp" & ChrW(108) & "Sp" & ChrW(109) & "Sp" & ChrW(110) & "Sp" & ChrW(111) & "Sp" & ChrW(112) & "Sp" & ChrW(113) & "Sp" & ChrW(114) & "Sp" & ChrW(115) & "Sp" & ChrW(116) & "Sp" & ChrW(117) & "Sp" & ChrW(118) & "Sp" & ChrW(119) & "Sp" & ChrW(120) & "Sp" & ChrW(121) & "Sp" & ChrW(122) & "Sp" & ChrW(123) & "Sp" & ChrW(124) & "Sp" & ChrW(125) & "Sp" & ChrW(126), "Sp"), 1, Evaluate("={89, 97, 115, 115, 101, 114}-64")), "")
End Sub

Sub ConvertBytesToString4()
Dim Es As String
Dim Splat() As Variant
Let Splat() = Array(ChrW(65), ChrW(66), ChrW(67), ChrW(68), ChrW(69), ChrW(70), ChrW(71), ChrW(72), ChrW(73), ChrW(74), ChrW(75), ChrW(76), ChrW(77), ChrW(78), ChrW(79), ChrW(80), ChrW(81), ChrW(82), ChrW(83), ChrW(84), ChrW(85), ChrW(86), ChrW(87), ChrW(88), ChrW(89), ChrW(90), ChrW(91), ChrW(92), ChrW(93), ChrW(94), ChrW(95), ChrW(96), ChrW(97), ChrW(98), ChrW(99), ChrW(100), ChrW(101), ChrW(102), ChrW(103), ChrW(104), ChrW(105), ChrW(106), ChrW(107), ChrW(108), ChrW(109), ChrW(110), ChrW(111), ChrW(112), ChrW(113), ChrW(114), ChrW(115), ChrW(116), ChrW(117), ChrW(118), ChrW(119), ChrW(120), ChrW(121), ChrW(122), ChrW(123), ChrW(124), ChrW(125), ChrW(126))
Let Es = Join(Application.Index(Splat(), 1, Evaluate("={89, 97, 115, 115, 101, 114}-64")), "")
' Or
Let Es = Join(Application.Index(Array(ChrW(65), ChrW(66), ChrW(67), ChrW(68), ChrW(69), ChrW(70), ChrW(71), ChrW(72), ChrW(73), ChrW(74), ChrW(75), ChrW(76), ChrW(77), ChrW(78), ChrW(79), ChrW(80), ChrW(81), ChrW(82), ChrW(83), ChrW(84), ChrW(85), ChrW(86), ChrW(87), ChrW(88), ChrW(89), ChrW(90), ChrW(91), ChrW(92), ChrW(93), ChrW(94), ChrW(95), ChrW(96), ChrW(97), ChrW(98), ChrW(99), ChrW(100), ChrW(101), ChrW(102), ChrW(103), ChrW(104), ChrW(105), ChrW(106), ChrW(107), ChrW(108), ChrW(109), ChrW(110), ChrW(111), ChrW(112), ChrW(113), ChrW(114), ChrW(115), ChrW(116), ChrW(117), ChrW(118), ChrW(119), ChrW(120), ChrW(121), ChrW(122), ChrW(123), ChrW(124), ChrW(125), ChrW(126)), 1, Evaluate("={89, 97, 115, 115, 101, 114}-64")), "")
End Sub

DocAElstein

11-01-2020, 04:59 PM

In support of this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35600

Sub MakeSomeStringsToCopyAndPasteIntoACode()
Dim CodeText As String
Dim Cnt As Long
Rem 1 For an ASCII array from Split
'1a) Spaces : Note: PROBLEM* If you use the Split way, then best is to avoid using a single character as the separator. Otherwise you may have problems if you want that character in your Horizontal Array of ASCII characters because it will be seen as a separator for Split. This means that you will not get that character in your list. Instead you will have 2 extra empty elements in your array, and all characters after where the character ( here the space) should have been will appear offset by one place to the right in the horizontal array
For Cnt = 1 To 200
Let CodeText = CodeText & " & "" "" & ChrW(" & Cnt & ")"
Next Cnt
Let CodeText = Mid(CodeText, 10) ' take of first 9 bits of Space&Space"Space"Space&Space
Debug.Print CodeText
Debug.Print
Let CodeText = "" ' Empty so that i can use the varable again below
'1b) Use any 2 characters as the seperator to avoid PROBLEM*
For Cnt = 1 To 200
Let CodeText = CodeText & " & ""Sp"" & ChrW(" & Cnt & ")"
Next Cnt
Let CodeText = Mid(CodeText, 11) ' take of first 10 bits of Space&Space"Sp"Space&Space
Debug.Print CodeText
Debug.Print
Rem 2 For ASCII array from VBA Array( ) function
Let CodeText = "" ' Empty so that i can use the varable again below
For Cnt = 1 To 200
Let CodeText = CodeText & ", ChrW(" & Cnt & ")"
Next Cnt
Let CodeText = Mid(CodeText, 3) ' take off the first two characters " ,"
Debug.Print CodeText
Debug.Print
End Sub
' http://www.eileenslounge.com/viewtopic.php?f=30&t=35600

DocAElstein

11-18-2020, 01:48 PM

Test post for later use

DocAElstein

11-30-2020, 02:47 PM

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559

On Error GoTo -1 is not equivalent of using Err.Clear. It does ( also) clear the error object, (equivalent of using Err.Clear ).
On Error GoTo -1 takes Excel out of the so called “exception state”. It also does clear the Err object registers, (equivalent of using Err.Clear ). But the later is secondary to its main function of “clearing the exception”.
The next macro has 3 identical erroring code lines . Just before each error we have an error handler, which we might expect would trap the error following it . All three error handlers are similar and are of the type On Error GoTo [LABEL] But we find that only the first two error handlers work….
In this macro the first and the second error handlers, of the type On Error GoTo [LABEL] are enabled, and so when an error occurs the coding jumps to the appropriate Label
The second Error handler would not have worked, that is to say the second error would not have been trapped without the code line of On Error GoTo -1 . On Error GoTo -1 has cleared the exception state.
The third error handler, also of the type On Error GoTo [LABEL], does not work. It does not work, that is to say the error is not trapped , because we are in the exception state. One of the characteristics of the exception state is that any attempt to enable an error handler will be ignored. Another characteristic of the exception state is that any enabled error handler, ( in this case the second one ) , will also be ignored.
It is also sometimes said in this situation that the second error handler is active and is still handling the second error. It cannot handle another error , and any further errors will be handled by the VBA default error handler

Sub OnErrorGoToMinus1_takes_Excel_out_of_the_so_called _exception_state() ' It also does clear the Err object registers, (equivalent of using Err.Clear ). But the later is secondary to its main function of "clearing the exception"
Dim Rslt As Double

On Error GoTo ErrHndlr1
Let Rslt = 1 / 0 ' This error gets trapped by ErrHndlr1
MsgBox Prompt:="You will never see this", Title:="You will never see this"
Exit Sub ' You will never come here in this demo macro, but its good practice to get in the habit of always doing this exit sub

ErrHndlr1:
Debug.Print Err.Number & vbCr & vbLf & Err.Description ' 11 Division durch Null
On Error GoTo -1 ' the next line will give us no error infomation because the On Error GoTo -1 has cleared the Err object registers
Debug.Print Err.Number & vbCr & vbLf & Err.Description ' 0

On Error GoTo ErrHndlr2 ' the main function of On Error GoTo -1 is to "clear the exception" which means this second error hanhler will work
Let Rslt = 1 / 0 ' This error gets trapped by ErrHndlr2
MsgBox Prompt:="You will never see this", Title:="You will never see this"
Exit Sub ' You will never come here in this demo macro, but its good practice to get in the habit of always doing this exit sub

ErrHndlr2:
Debug.Print Err.Number & vbCr & vbLf & Err.Description ' 11 Division durch Null
' I will not do On Error GoTo -1 and see what happens...

On Error GoTo ErrHndlr3
Let Rslt = 1 / 0 ' This will be handled by the VBA default error handler: The error will not be trapped by the second error handler , ErrHndlr2
MsgBox Prompt:="You will never see this", Title:="You will never see this"
Exit Sub ' You will never come here in this demo macro, but its good practice to get in the habit of always doing this exit sub

ErrHndlr3:
' You will never come here. The third error is not trapped: It will be handled by the VBA default error handler

End Sub

The following other error things also , in addition to their main function, clear the Err object registers –
_ On Error GoTo 0 ,
_ changing the error handler
_ Resume, ( Resume; Resume Next; Resume [label] )
-.....see next post

DocAElstein

11-30-2020, 02:47 PM

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559

_.....continued from last post

The following other error things also , in addition to their main function, clear the Err object registers –
_ On Error GoTo 0 ,
_ changing the error handler
_ Resume, ( Resume; Resume Next; Resume [label] ) ,
Here are 5 demos
1x On Error GoTo 0
1x changing the error handler
3x Resume, ( 1xResume; 1xResume Next; 1xResume [label] )

Sub OnErrorGoTo0ClearsErr() ' _ On Error GoTo 0
Dim Rslt As Double
On Error Resume Next ' In simple terms this allows the code to contiunue as if no error had occured. It is not quite that simple, for example, the Err and Error are filled
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / 0
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null
On Error GoTo 0 ' The main purpose of this is to disable our error handler and return to the default VBA error handler. As a secodary function it seems to clear the Err registers
Debug.Print Err & vbCr & vbLf & Error ' gives 0
End Sub

Sub ChangingTheErrorHandlerClearsErr() ' _ changing the error handler
Dim Rslt As Double
On Error Resume Next ' In simple terms this allows the code to contiunue as if no error had occured. It is not quite that simple, for example, the Err and Error are filled
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / 0
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null
On Error Resume Next
Debug.Print Err & vbCr & vbLf & Error ' gives 0 because I have changed the error handler , ( admitedly in this case changed it to the same type )
Let Rslt = 1 / 0
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null
On Error GoTo Bed
Debug.Print Err & vbCr & vbLf & Error ' gives 0 because I have changed the error handler
Let Rslt = 1 / 0
Exit Sub ' I don't need this since i never come here, but its good practice to get in the habit of having this above a typical Error handling code section.
Bed:
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null
End Sub

Sub Resume_ClearsErr() ' _ Resume, ( Resume )
Dim Rslt As Double, Demonostrator As Long
On Error GoTo ErrHndler ' In simple terms this tells VBA to go the the label, ErrHndler Note however that if an error causes me to go there, then I will then be in the exception state.
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / Demonostrator ' Initially this causes me to go to ErrHndler but then the Resume brings me back to re try this code line
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The Resume cleared the Err registers
Exit Sub

ErrHndler: ' Start of a what is commonly called an "error handling code section"
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
Let Demonostrator = 1 ' It is important to cure the problem causing the error here, or otherwise the next code line will cause an infinite loop because the next code line instructs VBA to go back and try the erroring code line again. Note also that the Resume in the next code line also clears the error exception and clears the Err registers
Resume ' This clears the exception, clears the Err registers, and instructs VBA to go back to the code line that errored and try again. Because it instructs VBA to go back and try the erroring code line again, It is important to cure the problem causing the error before this code line, or else we will have an infinite loop
End Sub
Sub Resume_Next_ClearsErr() ' 'Resume, ( Resume Next )
Dim Rslt As Double
On Error GoTo ErrHndler ' In simple terms this tells VBA to go the the label, ErrHndler Note however that if an error causes me to go there, then I will then be in the exception state.
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / 0 ' This causes me to go to ErrHndler The Resume Next brings me back to just after this code line
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The Resume Next cleared the Err registers
Exit Sub

ErrHndler: ' Start of a what is commonly called an "error handling code section"
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
Resume Next ' This clears the exception, clears the Err registers, and instructs VBA to go back to the code line just after that code line that errored
End Sub
Sub Resume_LABEL_ClearsErr() ' 'Resume, ( Resume [label] )
Dim Rslt As Double
On Error GoTo ErrHndler ' In simple terms this tells VBA to go the the label, ErrHndler Note however that if an error causes me to go there, then I will then be in the exception state.
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The default Err property is the error number, so in this situation Err is taken as Err.number The exact working of Error is unclear, but if an error occurs it seems to do a few things, and one of them is that it returns the error description
Let Rslt = 1 / 0 ' This causes me to go to ErrHndler The Resume Lbl brings me back to just after the label, Lbl:

Lbl:
Debug.Print Err & vbCr & vbLf & Error ' gives 0 The Resume Lbl cleared the Err registers
Exit Sub

ErrHndler: ' Start of what is commonly called an "error handling code section"
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
Resume Lbl ' This clears the exception, clears the Err registers, and instructs VBA to go to the code line just after the label Lbl:
End Sub

If we use On Error GoTo [LABEL] and then use Resume ( Resume; Resume Next; Resume [label] ) then we appear to be having something done very similar, or possibly exactly the same as On Error GoTo -1 , since the exception state is cleared and the Err object is cleared.
To demonstrate this we can do the last three routines again, and simply add another error handler , for example On Error Resume Next , after the return point, and follow this by an error. If the error is handled, that is to say we get no default VBA error message, then we know that the exception had been cleared previously. If it had not been cleared then the new error handler, On Error Resume Next , would have been ignored and we would have seen the default VBA error handler warning pop up message.

_..... continued in next post

DocAElstein

11-30-2020, 02:47 PM

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559

_.... from last post

If we use On Error GoTo [LABEL] and then use Resume ( Resume; Resume Next; Resume [label] ) then we appear to be having something done very similar, or possibly exactly the same as On Error GoTo -1 , since the exception state is cleared and the Err object is cleared.
To demonstrate this we can do the last three routines again, and simply add another error handler , for example On Error Resume Next , after the return point, and follow this by an error. If the error is handled, that is to say we get no default VBA error message, then we know that the exception had been cleared previously. If it had not been cleared then the new error handler, On Error Resume Next , would have been ignored and we would have seen the default VBA error handler warning pop up message.

' If we use On Error GoTo [LABEL] and then use Resume ( Resume; Resume Next; Resume [label] ) then we appear to be having something done very similar, or possibly exactly the same as On Error GoTo -1 , since the exception state is cleared and the Err object is cleared.
Sub Resume_ClearsErr_() ' _ Resume, ( Resume )
Dim Rslt As Double, Demonostrator As Long
On Error GoTo ErrHndler
Debug.Print Err & vbCr & vbLf & Error
Let Rslt = 1 / Demonostrator
Debug.Print Err & vbCr & vbLf & Error
On Error Resume Next ' This would be ignored if I was in exception state.
Let Rslt = 1 / 0 ' This does not give us an error , so the last code line worked, indicating that we were not in exception state
On Error GoTo 0 ' I do not need to do this since I am Exiting Sub in next code line. But it is good practice to get in the habit of doing this to return to normnal default VBA error handling if i know i am finished using the Error handler which I enabled
Exit Sub

ErrHndler:
Debug.Print Err & vbCr & vbLf & Error
Let Demonostrator = 1
Resume
End Sub
Sub Resume_Next_ClearsErr_() ' 'Resume, ( Resume Next )
Dim Rslt As Double
On Error GoTo ErrHndler
Debug.Print Err & vbCr & vbLf & Error
Let Rslt = 1 / 0
Debug.Print Err & vbCr & vbLf & Error
On Error Resume Next ' This would be ignored if I was in exception state.
Let Rslt = 1 / 0 ' This does not give us an error , so the last code line worked, indicating that we were not in exception state
On Error GoTo 0 ' I do not need to do this since I am Exiting Sub in next code line. But it is good practice to get in the habit of doing this to return to normnal default VBA error handling if i know i am finished using the Error handler which I enabled
Exit Sub

ErrHndler:
Debug.Print Err & vbCr & vbLf & Error
Resume Next
End Sub
Sub Resume_LABEL_ClearsErr_() ' 'Resume, ( Resume [label] )
Dim Rslt As Double
On Error GoTo ErrHndler
Debug.Print Err & vbCr & vbLf & Error
Let Rslt = 1 / 0

Lbl:
Debug.Print Err & vbCr & vbLf & Error
On Error Resume Next ' This would be ignored if I was in exception state.
Let Rslt = 1 / 0 ' This does not give us an error , so the last code line worked, indicating that we were not in exception state
On Error GoTo 0 ' I do not need to do this since I am Exiting Sub in next code line. But it is good practice to get in the habit of doing this to return to normnal default VBA error handling if i know i am finished using the Error handler which I enabled
Exit Sub

ErrHndler:
Debug.Print Err & vbCr & vbLf & Error
Resume Lbl
End Sub

DocAElstein

11-30-2020, 02:47 PM

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559

As far as I can tell , the Err object is always filled with information about the last error that occurred, and it seems to me that its sole purpose is to have information about the last error. It can be cleared with Err.Clear , and , is also cleared as a secondary function of other things, including On Error GoTo -1
( In fact it appears the Err is actually a function or an object, possibly working like something similar to Range(xx) which can be regarded as an object or property or function depending on how you use it. We can probably say that Err is a function which returns the Err object. I think that possibly Error is also a similar function. I am not sure exactly what it does, but one thing it does is return the same as Err.Decription, so it can be used in place of Err.Description )

The main purpose of On Error GoTo -1 is to take Excel out of the exception state. The exception state is generally caused by an error occurring. An exception to this being , possibly, of when On Error Resume Next is used: But this is not clear to anyone, as far as I can tell: Its not clear whether
either:
On Error Resume Next prevents the excepting state occurring
or
On Error Resume Next cause the exception state to be cleared immediately after an error occurs.

If On Error Resume Next is used and an error occurs, then something similar to doing On Error GoTo -1 happens. But it is not exactly the same, since the Err object is not cleared, as it is by On Error GoTo -1

Sub OnErrorResumeNext() ' If On Error Resume Next is used and an error occurs, then something similar to doing On Error GoTo -1 happens. But it is not exactly the same, since the Err object is not cleared, as it is by On Error GoTo -1
Dim Rslt As Double
On Error Resume Next
Let Rslt = 1 / 0 ' It is generally thought that we are not in the exception state, but the next line does tell us what error occured, so the On Error Resume Next has not simply done a On Error GoTo -1 , since On Error GoTo -1 would have resulted inj the Err object being cleared which would mean that the next code line retuned us 0
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
On Error GoTo Bed
Let Rslt = 1 / 0 ' We do not get a VBA default error here. We go to Bed: So the error handler worked indicating that we were not in the exception state
On Error GoTo 0 ' I do not need this or the next code line, but its good to get into the habit of turning off any used error handler and having an Exit Sub above a typiucal endind error handling code section
Exit Sub
Bed:
Debug.Print Err & vbCr & vbLf & Error ' gives 11 Division durch Null The Err register is always filled in all situatiuons when an error occurs, regardless of what error handler is or isn't in place.
End Sub

DocAElstein

11-30-2020, 02:47 PM

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559

The Exceptions State
The concept of the exception state is rarely understood.
The most noticeable effect of the error state is that further errors are dealt with by the default VBA error handling. It’s not relevant whether we are in the so called “error handling block” or not.

This frequently catches people out, in particular in a loop situation when error handling only works once, when they had been expecting it to trap all errors occurring: In the exception state, any enabled error handler won’t work again, and any attempt to use / enable another will be ignored.
( In this exception state, the On Error statement , On Error GoTo 0 , would do its main job of disabling any enabled error handler, but it won’t have any effect directly on anything, because it doesn’t clear the exception state. Its effect would only be noticed if the exception was cleared).

See here:
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
http://www.eileenslounge.com/viewtopic.php?p=278909#p278909
http://www.eileenslounge.com/viewtopic.php?p=278922#p278922

DocAElstein

11-30-2020, 02:47 PM

Some extra notes for a few Posts
http://www.eileenslounge.com/viewtopic.php?p=278892#p278892
https://www.myonlinetraininghub.com/error-handling-in-vba
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1
https://excelfox.com/forum/showthread.php/2239-Resume-On-Error-GoTo-0-1-GoTo-Error-Handling-Statements-Runtime-VBA-Error-Handling-ORNeRe-GoRoT-N0Nula-1?p=10559#post10559

hhfhhsfhhfaskh

DocAElstein

12-08-2020, 05:21 PM

macro or this Post:
https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15165&viewfull=1#post15165

Sub ConcatWithStyles() ' https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687
Rem 0a save the formulas, and replace with values
Dim arrFormulas() As Variant
Let arrFormulas() = Range("A1:F1").Formula
Let Range("A1:F1").Value = Range("A1:F1").Value
Dim X As Long, Cell As Range, Text As String, Position As Long
Range("A3").Value = Space(Evaluate("SUM(LEN(A1:F1))+COLUMNS(A1:F1)-1"))
Position = 1
' Application.ScreenUpdating = False
For Each Cell In Range("A1:F1")
With Range("A3")
.Characters(Position, Len(Cell.Value)).Text = Cell.Characters(1, Len(Cell.Value)).Text
For X = 1 To Len(Cell.Value)
With .Characters(Position + X - 1, 1).Font
.Name = Cell.Characters(X, 1).Font.Name
.Size = Cell.Characters(X, 1).Font.Size
.Bold = Cell.Characters(X, 1).Font.Bold
.Italic = Cell.Characters(X, 1).Font.Italic
.Underline = Cell.Characters(X, 1).Font.Underline
.Color = Cell.Characters(X, 1).Font.Color
.Strikethrough = Cell.Characters(X, 1).Font.Strikethrough
.Subscript = Cell.Characters(X, 1).Font.Subscript
.Superscript = Cell.Characters(X, 1).Font.Superscript
.TintAndShade = Cell.Characters(X, 1).Font.TintAndShade
.FontStyle = Cell.Characters(X, 1).Font.FontStyle
End With
Next
End With
Position = Position + Len(Cell.Value) + 1
Next
Application.ScreenUpdating = True
Rem 0b Put the formulas back
Let Range("A1:F1").Formula = arrFormulas()
End Sub

DocAElstein

12-10-2020, 04:03 PM

In support of these Thread answers:
' ' https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687 https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15170&viewfull=1#post15170

It was seen ( https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15168&viewfull=1#post15168
https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15167&viewfull=1#post15167 ) when solving the formula in cell issue, that the cells containing the formula can only have a single style for all characters in the cell. So it’s not necessary to loop through the characters in each cell when setting the style in the concatenated string from those cells.

' ' https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687 https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15170&viewfull=1#post15170
Sub ConcatWithStyles3()
Dim RngSel As Range: Set RngSel = Selection: Set RngSel = Range("A1:F1")
Rem 0a save any formulas, and replace with values
Dim arrFormulas() As Variant
Let arrFormulas() = RngSel.Formula ' Assuming wew select more than one cell, we will always be presented by .Value a 2 dimensional array, ( even if it is a single row or single column ) This codel line will error if we are using a selection of one cell, since in that case .Value only returns a single value which VBA syntax does not allow to be assigned to a dynmic array
Dim RwCnt As Long, ClmCnt As Long
' For RwCnt = 1 To RngSel.Rows.Count ' At each row we...._
' For ClmCnt = 1 To RngSel.Columns.Count
' If Left(arrFormulas(RwCnt, ClmCnt), 1) = "=" Then ' case a formula in cell
' Let RngSel.Item(RwCnt, ClmCnt).Value = RngSel.Item(RwCnt, ClmCnt).Value ' replace the formula with its value
' Else
' End If
' Next ClmCnt
' Next RwCnt
Dim RwsCnt As Long, ClmsCnt As Long, Itm As Long, ItmCnt As Long
Let ItmCnt = RngSel.Cells.Count
Let RwsCnt = RngSel.Rows.Count: Let ClmsCnt = RngSel.Columns.Count
For Itm = 1 To ItmCnt
If Left(arrFormulas(Int((Itm - 1) / ClmsCnt) + 1, Int((Itm - 1) / RwsCnt) + 1), 1) = "=" Then ' case a formula in cell
Let RngSel.Item(Itm).Value = RngSel.Item(Itm).Value ' replace the formula with its value
Else
End If
Next Itm

Dim ExChr As Long, ACel As Range, TeExt As String, Position As Long
' Let Range("A3").Value = Space(Evaluate("SUM(LEN(A1:F1))+COLUMNS(A1:F1)-1")) ' This makes a teExt of spaces. The number of spaces is the sum of all the teExt in the cells + one less than the number of cells. This gives us enough characters for all the teExt and a space betweeen them
Let Range("A3").Value = Space(Evaluate("=SUM(LEN(" & RngSel.Address & "))+COLUMNS(" & RngSel.Address & ")-1"))
Let Position = 1
' Let Application.ScreenUpdating = False ' adding this code line may speed the macro up a bit

Let Itm = 0
For Each ACel In RngSel
Let Itm = Itm + 1
With Range("A3") ' The range ( cell ) used for final output of concatenated cell text with styles
'here in next code line we put the characters in...
.Characters(Position, Len(ACel.Value)).Text = ACel.Value ' ACel.Characters(1, Len(ACel.Value)).Text ' ACel.Value This puts the charascters
If Left(arrFormulas(Int((Itm - 1) / ClmsCnt) + 1, Int((Itm - 1) / RwsCnt) + 1), 1) = "=" Then ' We only need to consider the cell style, since individual styles on characters are not possible in a cell with a formula in it
' ....it's not necessary to loop through the characters in each cell when setting the style in the concatenated string from those cells containing formulas
With .Characters(Position, Len(ACel.Value)).Font ' all the characters from the current cell in the final concatenated string
.Name = ACel.Font.Name
.Size = ACel.Font.Size
.Bold = ACel.Font.Bold
.Italic = ACel.Font.Italic
.Underline = ACel.Font.Underline
.Color = ACel.Font.Color
.Strikethrough = ACel.Font.Strikethrough
.Subscript = ACel.Font.Subscript
.Superscript = ACel.Font.Superscript
.TintAndShade = ACel.Font.TintAndShade
.FontStyle = ACel.Font.FontStyle
End With '

Else ' we need to consider all characters in the cell
For ExChr = 1 To Len(ACel.Value) ' We are looping for all the tExt Chraracters in the current cell text
' here in the next With End With section the next character in the final concatenated string is given the styles that it had in the cell it came from
With .Characters(Position + ExChr - 1, 1).Font ' A single character in the final concatenated string
.Name = ACel.Characters(ExChr, 1).Font.Name
.Size = ACel.Characters(ExChr, 1).Font.Size
.Bold = ACel.Characters(ExChr, 1).Font.Bold
.Italic = ACel.Characters(ExChr, 1).Font.Italic
.Underline = ACel.Characters(ExChr, 1).Font.Underline
.Color = ACel.Characters(ExChr, 1).Font.Color
.Strikethrough = ACel.Characters(ExChr, 1).Font.Strikethrough
.Subscript = ACel.Characters(ExChr, 1).Font.Subscript
.Superscript = ACel.Characters(ExChr, 1).Font.Superscript
.TintAndShade = ACel.Characters(ExChr, 1).Font.TintAndShade
.FontStyle = ACel.Characters(ExChr, 1).Font.FontStyle
End With '
Next ExChr
End If
End With
Position = Position + Len(ACel.Value) + 1 ' This takes us to posiion at the end of the current cell text +1 ( +1
Next ACel
Application.ScreenUpdating = True
Rem 0b Put the formulas back
For RwCnt = 1 To RngSel.Rows.Count ' At each row we...._
For ClmCnt = 1 To RngSel.Columns.Count
If Left(arrFormulas(RwCnt, ClmCnt), 1) = "=" Then ' ' case a formula was in cell
Let RngSel.Item(RwCnt, ClmCnt).Formula = arrFormulas(RwCnt, ClmCnt) ' we put the formula back
Else
' we didnt have a formula , so we do nothing to the cell - if we did then we would likely get just one style in the cell - a text with more than one style would revert to one single style throughout
End If
Next ClmCnt
Next RwCnt

End Sub

DocAElstein

01-15-2021, 10:53 PM

Coding for this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
and this post
https://eileenslounge.com/viewtopic.php?p=279798#p279798

Full version:

Sub Test() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
Dim Indx As Long ' the index of the element to be removed - for this example it can be chosen to be 0 or 1 or 2 or 3 or 4
Let Indx = 4

Dim arr1D() As Variant
Let arr1D() = Array(1, 2, 3, 4, 5)
Dim Joint As String
Let Joint = Join(arr1D(), "|"): Debug.Print Joint ' 1|2|3|4|5 ' - make sure you use a seperator that does not appear in any array element
Let Joint = "|" & Joint & "|": Debug.Print Joint ' |1|2|3|4|5| ' - needed so that I can get at the last and first element also
Dim CrackedJoint As String ' For cracked Joint
' I can use Application.WorksheetFunction.Substitute to pick out specific seperators , so I will replace the one before and after with some word like "Crack"
Let CrackedJoint = Application.WorksheetFunction.Substitute(Joint, "|", "Crack2", Indx + 2): Debug.Print CrackedJoint ' |1|2|3|4|5Crack2 ' ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Let CrackedJoint = Application.WorksheetFunction.Substitute(CrackedJo int, "|", "Crack1", Indx + 1): Debug.Print CrackedJoint ' |1|2|3|4Crack15Crack2
Dim Crack1 As Long, Crack2 As Long ' The positions of the cracks
Let Crack1 = InStr(1, CrackedJoint, "Crack1", vbBinaryCompare): Debug.Print Crack1 ' 9
Let Crack2 = InStr(1, CrackedJoint, "Crack2", vbBinaryCompare): Debug.Print Crack2 ' 16
Dim LeftBit As String, RightBit As String
Let LeftBit = Left$(CrackedJoint, Crack1 - 1): Debug.Print LeftBit ' |1|2|3|4
Let RightBit = "|" & Mid$(CrackedJoint, Crack2 + 6): Debug.Print RightBit ' |
Dim JointedJoint As String
Let JointedJoint = LeftBit & RightBit: Debug.Print JointedJoint ' |1|2|3|4|
Let JointedJoint = Mid(JointedJoint, 2, Len(JointedJoint) - 2): Debug.Print JointedJoint ' 1|2|3|4
Dim arr1DOut() As String
Let arr1DOut() = Split(JointedJoint, "|", -1, vbBinaryCompare)
' The above array is of element types of String , so we can't assign that to out original Variant type array. We can convert with
Let arr1D() = Application.Index(arr1DOut(), Evaluate("={1,1,1,1}"), Evaluate("={1,2,3,4}")) ' https://www.excelforum.com/tips-and-tutorials/758402-vba-working-with-areas-within-2d-arrays.html#post5408376
Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:D)/Column(A:D)"), Evaluate("=Column(A:D)")) ' https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5410028
Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '

' or
Let arr1D() = Application.Index(arr1DOut(), 1, 0) '

End Sub

“One liner ( almost ) “ versions

Sub Test2()
Dim Indx As Long
Let Indx = 4

Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)
Let arr1D() = Application.Index(Split(Mid(Left$(Application.Work sheetFunction.Substitute(Application.WorksheetFunc tion.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute (Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '

End Sub

Sub Test3()
Dim Indx As Long
Let Indx = 1

Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)
Let arr1D() = Application.Index(Split(Mid(Left$(Application.Work sheetFunction.Substitute(Application.WorksheetFunc tion.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute (Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '

End Sub

Function version

Sub testFunction()
Dim arr1D() As Variant: Let arr1D() = Array(1, "2", 3, 4, 5)
Let arr1D() = DeleteItem(arr1D(), 1)
End Sub

Function DeleteItem(ByVal Var As Variant, Indx As Long) As Variant
Let DeleteItem = Application.Index(Split(Mid(Left$(Application.Work sheetFunction.Substitute(Application.WorksheetFunc tion.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute (Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Appl ication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(App lication.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")")) '
End Function

DocAElstein

01-15-2021, 10:58 PM

Coding for this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
and this post
https://eileenslounge.com/viewtopic.php?p=279861&sid=880ca3b983884fbedb1ea146e8de06b5#p279861

Sub DeleteItemByIndexIn1DArraySHG1() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980&p=279809#p279809 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
Dim Indx As Long '
Let Indx = 1 ' 1 is for deleting the first element

Dim arr1D() As Variant
Let arr1D() = Array(1, 2, 3, 4, 5)
Dim Joint As String
Let Joint = Join(arr1D(), ","): Debug.Print Joint ' 1,2,3,4,5 ' - make sure you use a seperator that does not appear in any array element

Dim Pos1 As Long, Pos2 As Long
Let Pos1 = Evaluate("=Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))")
Debug.Print Pos1 ' 1
Let Pos2 = Evaluate("=Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))")
Debug.Print Pos2 ' 3
Dim LeftBit As String, RightBit As String
Let LeftBit = Left$("," & Joint, Pos1 - 1): Debug.Print LeftBit ' nothing there '
Let LeftBit = Evaluate("=Left(""," & Joint & """, " & Pos1 - 1 & ")"): Debug.Print LeftBit ' nothing there
Let RightBit = "," & Mid$("," & Joint & ",", Pos2 + 1): Debug.Print RightBit ' ,2,3,4,5,
' The MID spreadsheet function is less helpful since it must have the third argument ( in VBA MID the third length argument is optional
Let RightBit = "," & Right$("," & Joint & ",", Len(Joint) - (Pos2 - 2)): Debug.Print RightBit ' ,2,3,4,5, ' we don't want to take off the , and Joint is one less than Joint & "," so we take off in total 2 less
Let RightBit = Evaluate("="",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print RightBit ' ,2,3,4,5, '

Rem Joining the two and trimming odff the leading and trailing seperators
Dim JointedJoint As String
'Let JointedJoint = LeftBit & RightBit: Debug.Print JointedJoint ' ,2,3,4,5,
'Let JointedJoint = Evaluate("=""" & LeftBit & RightBit & """"): Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=" & """" & LeftBit & RightBit & """"): Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=" & """" & LeftBit & ",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=Left(""," & Joint & """, " & Pos1 - 1 & ")&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")
Debug.Print JointedJoint ' ,2,3,4,5,

'Let JointedJoint = Mid(JointedJoint, 2, Len(JointedJoint) - 2): Debug.Print JointedJoint ' 2,3,4,5
'Debug.Print JointedJoint ' 2,3,4,5
'Let JointedJoint = Evaluate("=Mid(Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2)),2,Len(Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))))") ' Evaluate string has 355 characters so it wont work
'Debug.Print JointedJoint
Let JointedJoint = Mid(Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)
Debug.Print JointedJoint ' 2,3,4,5

' replace Joint with Join(arr1D(), ",")
Let JointedJoint = Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)
Debug.Print JointedJoint ' 2,3,4,5

' Get the string array back
Dim arr1DOut() As String
Let arr1DOut() = Split(JointedJoint, ",", -1, vbBinaryCompare): Let arr1DOut() = Split(JointedJoint, ",")
Let arr1DOut() = Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ",")
' The spilt has returned string Elements, so we can't directly assign to the original array
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("={1,1,1,1}"), Evaluate("={1,2,3,4}")) ' https://www.excelforum.com/tips-and-tutorials/758402-vba-working-with-areas-within-2d-arrays.html#post5408376
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:D)/Column(A:D)"), Evaluate("=Column(A:D)")) ' https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5410028
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '

' or
' Let arr1D() = Application.Index(arr1DOut(), 1, 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%c3%a2%e2%82%ac%e2%80%9c-Application-Index
Let arr1D() = Application.Index(Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ","), 1, 0) ' Full workings: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218

End Sub

Or ....

Sub DeleteItemByIndexIn1DArraySHG2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980&p=279809#p279809 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
Dim Indx As Long '
Let Indx = 1 ' 1 is for deleting the first element
Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)

Let arr1D() = Application.Index(Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ","), 1, 0) ' Full workings: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
End Sub

Some explanations in next post

DocAElstein

01-16-2021, 02:24 PM

( In this example, Indx, is the Index number of the element that we want to remove starting from 1 – For the first element Indx must be given as 1

In Words , this is how the main code line works…( taking the example of wanting to remove the first element
My 1 D array , for example , {1,2,3,4,5} , is turned into a single text string, “1,2,3,4,5”. ( The separating thing, a comma in this case, is arbitrary. You should choose some character that is not likely to appear in any of your data.)
The next thing to do is add additional leading and trailing separating things ( commas in this example ) , so in the example it would then look like “,1,2,3,4,5,”

Now we use this sort of bit a lot.. Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx +1 & "))
Substitute is used to change the comma before the element you want to some other arbitrary separating thing.
So lets say we used a | and are wanting the first element ( Indx=1 ) removed. We then would have like
“|1,2,3,4,5,”
We then do a Find to get the position of that |
In other words,
The Substitute gives us this "|1,2,3,4,5,"
The Find looks for the | and gives us 1
Substitute is used again to change the comma after the element you want to some other arbitrary separating thing.
So lets say we used a | again. ( we are still wanting the first element) We then would have like
“,1|2,3,4,5,”
We then do a Find to get the position of that |
In other words,
The Substitute gives us this ",1|2,3,4,5,"
The Find looks for that | and gives us 3
Here is the last bit in close to the final code line:

Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)

So we now know where the start and the end is of the element that we want to remove are
We can use this information to determine the string before, and to determine the string after, the element that we want to remove.
So we put those two strings together and that gives us the original string without the element that we want to remove.
Finally we Split that text back into an array

( Once again we will have all string elements out, regardless of what element types we have in our original array )

DocAElstein

01-16-2021, 02:25 PM

post for later use..
http://i.imgur.com/dol9tfQ.jpg
http://i.imgur.com/Ucpj9pZ.jpg
http://i.imgur.com/mtLzChH.jpg
http://i.imgur.com/N2PbR0C.jpg
http://i.imgur.com/Nzfnk90.jpg
http://i.imgur.com/rnYpqNh.jpg
http://i.imgur.com/RODuXQl.jpg
http://i.imgur.com/zpWglC9.jpg

Hello
I tried it , second one, http://i.imgur.com/wL6hN1c.jpg
It did not work

http://i.imgur.com/Z7bl5cc.jpg
http://i.imgur.com/NG2ICxa.jpg
http://i.imgur.com/EpDQOXB.jpg

Alan

DocAElstein

01-16-2021, 02:25 PM

post for later use-

DocAElstein

01-16-2021, 02:25 PM

post for later use

DocAElstein

01-16-2021, 02:25 PM

post for later use

DocAElstein

01-16-2021, 10:13 PM

Test...

MID( SUBSTITUTE(Text,Delim,REPT(" ",LEN(Text))) , (element*LEN(Text)) - (LEN(Text)-1) , LEN(Text) )

MID( SUBSTITUTE(Text,Delim,REPT(" ",LEN(Text))) , (element*LEN(Text)) - ( LEN(Text) ) , LEN(Text) )
Row\Col
A
B
C

1
What is pseudo is in the Cell to the left ( column B )

2Example get the first thing, 1 from the Text string "1,3,5"
1,3,5 my original test text

3Length
5the length in characters of my original test text

4( Rept " " ) x Length
5 spaces like "12345"

5Substitute in the original string ( B2 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters

6I apply to B5 the MID function starting at (1x5)-(5-1)=1 and for a length of 5
1____ like "11234"

7I apply to B5 the MID function starting at (1x5)-(5)=0 and for a length of 5
#VALUE!Excel doesn't forgive me for trying to start at 0 !!!!

8

9Example get the second thing, 3 from the Text string "1,3,5"
1,3,5 my original test text

10Length
5the length in characters of my original test text

11( Rept " " ) x Length
5 spaces like "12345"

12Substitute in the original string ( B9 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters

13I apply to B12 the MID function starting at (2x5)-(5-1)=6 and for a length of 5
_3___like "13123"

14I apply to B12 the MID function starting at (2x5)-(5)=5 and for a length of 5
__3__like "12312"

15

16Example get the third thing, 5 from the Text string "1,3,5"
1,3,5 my original test text

17Length
5the length in characters of my original test text

18( Rept " " ) x Length
5 spaces like "12345"

19Substitute in the original string ( B16 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters

20I apply to B19 the MID function starting at (3x5)-(5-1)=11 and for a length of 5
__5like "125" Note: I try to do length 5, but Excel forgives me and gives the 3 it has available

21I apply to B19 the MID function starting at (1x5)-(5)=0 and for a length of 5
___5like "1235" Note: I try to do length 5, but Excel forgives me and gives the 4 it has available

Row\Col
B

1

2
1,3,5

3
=LEN(B2)

4
=REPT(" ",B3)

5
=SUBSTITUTE(B2,",",B4)

6
=MID(B5,(1*B3)-(B3-1),B3)

7
=MID(B5,(1*B3)-(B3),B3)

8

9
1,3,5

10
=LEN(B9)

11
=REPT(" ",B10)

12
=SUBSTITUTE(B9,",",B11)

13
=MID(B12,(2*B10)-(B10-1),B10)

14
=MID(B12,(2*B10)-(B10),B10)

15

16
1,3,5

17
=LEN(B16)

18
=REPT(" ",B17)

19
=SUBSTITUTE(B16,",",B18)

20
=MID(B19,(3*B17)-(B17-1),B17)

21
=MID(B19,(3*B17)-(B17),B17)

Row\Col
A
B
C

7I apply to B5 the MID function starting at (1x5)-(5)=0 and for a length of 5
#VALUE!Excel doesn't forgive me for trying to start at 0 when using MID

DocAElstein

01-16-2021, 10:13 PM

Test...

MID( SUBSTITUTE(Text,Delim,REPT(" ",LEN(Text))) , (element*LEN(Text)) - (LEN(Text)-1) , LEN(Text) )

MID( SUBSTITUTE(Text,Delim,REPT(" ",LEN(Text))) , (element*LEN(Text)) - ( LEN(Text) ) , LEN(Text) )
Row\Col
A
B
C

1
What is pseudo is in the Cell to the left ( column B )

2Example get the first thing, 1 from the Text string "1,3,5"
1,3,5 my original test text

3Length
5the length in characters of my original test text

4( Rept " " ) x Length
5 spaces like "12345"

5Substitute in the original string ( B2 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters

6I apply to B5 the MID function starting at (1x5)-(5-1)=1 and for a length of 5
1____ like "11234"

7I apply to B5 the MID function starting at (1x5)-(5)=0 and for a length of 5
#VALUE!Excel doesn't forgive me for trying to start at 0 !!!!

8

9Example get the second thing, 3 from the Text string "1,3,5"
1,3,5 my original test text

10Length
5the length in characters of my original test text

11( Rept " " ) x Length
5 spaces like "12345"

12Substitute in the original string ( B9 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters

13I apply to B12 the MID function starting at (2x5)-(5-1)=6 and for a length of 5
_3___like "13123"

14I apply to B12 the MID function starting at (2x5)-(5)=5 and for a length of 5
__3__like "12312"

15

16Example get the third thing, 5 from the Text string "1,3,5"
1,3,5 my original test text

17Length
5the length in characters of my original test text

18( Rept " " ) x Length
5 spaces like "12345"

19Substitute in the original string ( B16 ) 5 spaces for each comma seperator
1_____3_____5 like "1123453123455" is 13 characters

20I apply to B19 the MID function starting at (3x5)-(5-1)=11 and for a length of 5
__5like "125" Note: I try to do length 5, but Excel forgives me and gives the 3 it has available

21I apply to B19 the MID function starting at (1x5)-(5)=0 and for a length of 5
___5like "1235" Note: I try to do length 5, but Excel forgives me and gives the 4 it has available

Row\Col
B

1

2
1,3,5

3
=LEN(B2)

4
=REPT(" ",B3)

5
=SUBSTITUTE(B2,",",B4)

6
=MID(B5,(1*B3)-(B3-1),B3)

7
=MID(B5,(1*B3)-(B3),B3)

8

9
1,3,5

10
=LEN(B9)

11
=REPT(" ",B10)

12
=SUBSTITUTE(B9,",",B11)

13
=MID(B12,(2*B10)-(B10-1),B10)

14
=MID(B12,(2*B10)-(B10),B10)

15

16
1,3,5

17
=LEN(B16)

18
=REPT(" ",B17)

19
=SUBSTITUTE(B16,",",B18)

20
=MID(B19,(3*B17)-(B17-1),B17)

21
=MID(B19,(3*B17)-(B17),B17)

Row\Col
A
B
C

7I apply to B5 the MID function starting at (1x5)-(5)=0 and for a length of 5
#VALUE!Excel doesn't forgive me for trying to start at 0 when using MID

DocAElstein

01-24-2021, 07:32 PM

post to use later

DocAElstein

01-24-2021, 07:32 PM

post to use later

DocAElstein

01-24-2021, 07:33 PM

In support of this post

Before Source worksheet

_____ Workbook: Transfer data_marasAlan_1.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAH
1NumberUnique IDNameTitlePlatformFilterSalaryAdd1Add2Add3Add4Add 5Add6Add7Add8Add9Add10Add11Add12copy1copy2copy3cop y4copy5copy6copy7Total

433658LaluLeadCFilter23000660606000000011204

92563Vidu_xxManagerJavaFilter240000000000000000812 00121

102563Vidu_maxManagerJavaFilter2425000000000000008 1200222

122563ViduManagerJavaFilter24000000000000000081300 21

162354SaiOperatorC++Filter215000023002000000024000 24

172333FranOperatorSQLFilter21500010000000010000000

183239Jack_maxLeadSQLFilter25660000000450000440840 20

193239JackLeadSQLFilter2300000000046000044484024

234222AndyOperatorJavaFilter2150000000000000040014 826

241123RamManagerJavaFilter240000300000055001200003 15

36126SomOperatorCFilter215000207000000333004060223 2
Worksheet: Sheet1

DocAElstein

01-24-2021, 07:33 PM

In support of this post

Before destination worksheet

_____ Workbook: Workbook2_1.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOP
1Unique IDNameTitlePlatformSalarySumcopy1copy2copy3copy4co py5copy6copy7

2
Worksheet: Sheet1

Destination After

_____ Workbook: Workbook2_1.xlsx ( Using Excel 2007 32 bit )
Row\Col
B
C
D
E
F
G
H
I
J
K
L
M
N
O

1
Unique ID
Name
Title
Platform
Salary
Sum
copy1
copy2
copy3
copy4
copy5
copy6
copy7

23658LaluLeadC
£300
24

1
1
2

3563Vidu_xxManagerJava
£400
0

8
12

1

4563Vidu_maxManagerJava
£425
0

8
12

2

5563ViduManagerJava
£400
0

8
13

6354SaiOperatorC++
£150
25

24

7333FranOperatorSQL
£150
2

8239Jack_maxLeadSQL
£566
45
4
4

8
4

9239JackLeadSQL
£300
46
4
4
4
8
4

10222AndyOperatorJava
£150
0

4

14
8

11123RamManagerJava
£400
58
12

3

1226SomOperatorC
£150
342

4

6

22
Worksheet: Sheet1

DocAElstein

01-24-2021, 07:33 PM

Macro for last two posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()
Dim a(), arrOut__(), Cls(), Cls_v() As String, Rws(), asum
Dim Rng As Range, Rng_v As Range, Rng_vVls() As Variant, cel As Range
Dim i As Integer, ii As Integer
Dim Pth As String: Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const pth = "c:\Users\User\Downloads\" '<---- use own path
Const wnm = "Workbook2_1.xlsx" 'your workbook name
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = Range("a1:aH" & 36 & "") ' Range("a1:ag" & 36 & "") ' hard coded for testing .UsedRange.Rows.Count)
Let a() = Rng.Value ' The main source data range
Let Cls() = Rng.Rows(1).Value ' The header row
ReDim Rws(1 To UBound(a)) ' The row indicies of the rows we are intersted in from the filtered range ##### this will likely be much too big at this stage but we will correct that later
End With
Rem 2 building a single column array for the summed colums
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' for maras datas this will be 11 data rows and the header 0 12 rows in total
'Rng_vVls() = Rng_v.Value2 ' This is for my testing only - this will give me just first area
If Rng_v.Count > 1 Then
ReDim asum(1 To Rng_v.Count) ' 1 D array to hold sum values - I wanted to sum from column O to column Z and transfer those sum to destination at column I
For Each cel In Rng_v
If cel.Row > 1 And cel.Value <> "" Then
Let ii = ii + 1
Let asum(ii) = Evaluate("sum(o" & cel.Row & ": z" & cel.Row & ")") ' Evaluate Range way to sum a range
Let i = i + 1
Let Rws(i) = cel.Row
End If
Next
If ii > 0 Then ReDim Preserve asum(1 To ii) ' Our array is one element too big with an empty element, so thhis takes off that extra unwanted element
If i > 0 Then ReDim Preserve Rws(1 To i) ' Our array is much too big so this makes it the correct size ####
Else ' case no data rows, only a header row
End If
If Rng_v.Count = 1 Or i = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
Rem 2
Workbooks.Open Filename:=Pth & wnm
'2a) Gets the column indicies of the columns wanted from the data worksheet
With ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant
vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , x , 3 , 4 , 5 , 11 , x , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let Cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
'2b) Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
Let arrOut__() = Application.Index(a(), Application.Transpose(Rws()), Cls_v()) ' Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
'2c) arrOut__() is not quite the final array we want. Its condensed missing out a couple of empty columns, so in code section '2b) we pick out the sections we want and put them in the appropriate place.
With .Range("B2") ' UsedRange.Offset(1)
'.ClearContents
.Resize(UBound(Rws()), 1) = Application.Index(arrOut__(), Evaluate("row(1:" & UBound(Rws()) & ")"), 1) ' column B in output
.Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), (Evaluate("row(1:" & UBound(Rws()) & ")")), Application.Transpose(Evaluate("row(2:" & UBound(arrOut__(), 2) & ")"))) ' column D to G
.Offset(, 7).Cells(1).Resize(UBound(Rws()), UBound(arrOut__(), 2) - 5).Value = Application.Index(arrOut__(), Evaluate("row(1:" & UBound(Rws()) & ")"), Application.Transpose(Evaluate("row(6:" & UBound(arrOut__(), 2) & ")"))) ' column I to O
.Offset(, 6).Cells(1).Resize(UBound(Rws())) = Application.Transpose(asum) ' sums column H
End With
End With
'.Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
End Sub

_._______________________________

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

DocAElstein

01-24-2021, 07:33 PM

In support of this post

Source Workbook

_____ Workbook: Transfer data_marasAlan_2.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHA I
1NumberUnique IDNameTitlePlatformFilterSalaryAdd1Add2Add3Add4Add 5Add6Add7Add8Add9Add10Add11Add12copy1copy2copy3cop y4copy5copy6copy7

21123RamManagerJavaFilter2£400355123222

9126SomOperatorCFilter2£1501,013

102354SaiOperatorC++Filter2£150232241,126

172563ViduManagerJavaFilter2£400812147

183239JackLeadSQLFilter2£300454484149

194222AndyOperatorJavaFilter2£1504148151

242333FranOperatorSQLFilter2£15011161

2533658LaluLeadCFilter2£3006666112163

30

31
Worksheet: Sheet1

DocAElstein

01-24-2021, 07:33 PM

In support of this post

Designation workbook before

_____ Workbook: Workbook2_2.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQ
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7

2
Worksheet: sheet1

Destination workbook after running macro Sub Transfer_marasAlan_2()

_____ Workbook: Workbook2_2.xlsx ( Using Excel 2007 32 bit )
Row\ColBCDEFGHIJKLMNOP
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7

2123RamManagerJava£40058123222

326SomOperatorC£15001,013

4354SaiOperatorC++£15025241,126

5563ViduManagerJava£4000812147

6239JackLeadSQL£300454484149

7222AndyOperatorJava£15004148151

8333FranOperatorSQL£1502161

93658LaluLeadC£30024112163

10
Worksheet: sheet1

DocAElstein

01-24-2021, 07:33 PM

macro for last two posts

Option Explicit
Sub Transfer_marasAlan_2() '
Dim a(), Cls(), Cls_v() As String, Rws(), aSum(), arrOut__()
Dim Rng As Range, Rng_v As Range, Cel As Range, WbDest As Workbook
Dim i As Integer, ii As Integer
Dim Pth As String
Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const Pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const wnm = "Workbook2_2.xlsx" 'your workbook name
' Application.ScreenUpdating = False
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = .Range("a1:ag" & 25 & "") ' Hardcoded for demonstration purposes .UsedRange.Rows.Count)
Let a() = Rng.Value ' main complete data range
Let Cls() = Rng.Rows(1).Value ' header row array
ReDim Rws(1 To UBound(a)) ' This will be much too big initially - its the full all row size, but we will only want a reduced filtered number of rows - later #### this will be corrected
End With
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gets just the range we see, so will be likely a range of lots of areas
If Rng_v.Count > 1 Then
Rem 2 building a single column array for the summed colums
ReDim aSum(1 To Rng_v.Count) ' this is "one row too big" **
For Each Cel In Rng_v
If Cel.Row > 1 And Cel.Value <> "" Then
Let i = i + 1
Let aSum(i) = Evaluate("sum('[Transfer data_marasAlan_2.xlsm]Sheet1'!o" & Cel.Row & ": '[Transfer data_marasAlan_2.xlsm]Sheet1'!z" & Cel.Row & ")")
Let Rws(i) = Cel.Row
End If
Next
If i > 0 Then
ReDim Preserve aSum(1 To i) ' ** this sets the correct size
ReDim Preserve Rws(1 To i) ' #### this sets just enought row size for our final output array
Let aSum() = Application.Transpose(aSum()) ' we need a "virtical" "column" array
Let Rws() = Application.Transpose(Rws()) ' we need a virtical array in the second argumant of the Typical arrOut()=AppIndex(arrIn(), Rws(), Clms()) code line
End If
Else ' case only header range visible
End If
If Rng_v.Count = 1 Or i = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Set WbDest = Workbooks(wnm) ' will error if workbook is not yet open
If Err.Number > 0 Then Workbooks.Open Filename:=Pth & wnm ' we test to see if we have an error and if we do themn we kknow to open the workbook
On Error GoTo 0
Set WbDest = ActiveWorkbook
'2a) Gets the column indicies of the columns wanted from the data worksheet
With WbDest ' ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant ' just for demo purposes
Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , error , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , x, , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let Cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
'2b) Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
Let arrOut__() = Application.Index(a(), Rws(), Cls_v())
'2c) arrOut__() is not quite the final array we want. Its condensed missing out a couple of empty columns, so in code section '2c) we pick out the sections we want and put them in the appropriate place. In addition we paste in the sum columns that we got in section Rem 2
With Range("B2") ' .UsedRange.Offset(1)
.Resize(UBound(Rws), 1) = arrOut__() ' arrOut__() is 8 columns, but this linw will just put the first column in
Let Rws() = Evaluate("row(1:" & UBound(arrOut__()) & ")") ' for convenience again we are using the variable Rws() for sequential rows for our arrOut__() as we want all rows in the order that they are there
.Offset(, 2).Cells(1).Resize(UBound(arrOut__()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5)) ' columns D to G
.Offset(, 8).Cells(1).Resize(UBound(Rws()), UBound(arrOut__(), 2) - 5).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12)) ' columns J to P
.Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum() ' put the totals column in I
End With
End With
' .Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
End Sub

_._______________________________

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

DocAElstein

01-24-2021, 07:33 PM

In support of this post

Source Workbook

_____ Workbook: Transfer data_marasAlan_3.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHA I
1NumberUnique IDNameTitlePlatformFilterSalaryAdd1Add2Add3Add4Add 5Add6Add7Add8Add9Add10Add11Add12copy1copy2copy3cop y4copy5copy6copy7Totalgrandtotal

433658LaluLeadCFilter2£3006666112
4
£1,200

92563ViduManagerJavaFilter2£400812
20
£8,000

102563ViduManagerJavaFilter2£425812
20
£8,500

122563ViduManagerJavaFilter2£400813
21
£8,400

162354SaiOperatorC++Filter2£15023224
24
£3,600

172333FranOperatorSQLFilter2£15011

£0

183239JackLeadSQLFilter2£566454484
20
£11,320

193239JackLeadSQLFilter2£3004644484
24
£7,200

234222AndyOperatorJavaFilter2£1504148
26
£3,900

241123RamManagerJavaFilter2£400355123
15

36126SomOperatorCFilter2£150

Worksheet: Sheet1

DocAElstein

01-24-2021, 07:33 PM

In support of this post

Before destination

_____ Workbook: Workbook2_3.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRST
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7

2
Worksheet: Sheet1

After Destination

_____ Workbook: Workbook2_3.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRS
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7

23658LaluLeadC£300244112

3563ViduManagerJava£425020812

4354SaiOperatorC++£150252424

5333FranOperatorSQL£1502

6239JackLeadSQL£56645204484

7222AndyOperatorJava£1500264148

8123RamManagerJava£4005815123

926SomOperatorC£1500

10
Worksheet: Sheet1

DocAElstein

01-24-2021, 07:33 PM

macro for last two posts

Option Explicit
Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624
Dim a(), cls_v() As String, Rws(), aSum(), arrOut__(), JagdDikIt()
Dim Rng As Range, Rng_v As Range, cel As Range
Dim Wrbk As Workbook, Rw As Long
Dim Pth As String
Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const Wnm = "Workbook2_3.xlsx" 'your workbook name
' Application.ScreenUpdating = False
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = .Range("a1:ai" & 36 & "") ' main data range hard coded to 36 for testing and demonstration .UsedRange.Rows.Count)
Let a() = Rng.Value ' all data values in the source. This will end up in the tyopical arrOut()=AppIndex( a(), Rws(), Clms() )
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gives us the range we see , (it is likely as a collection of areas) in the ID column
If Rng_v.Count > 1 Then
Rem 2 Make the sums column array, aSum() , and while we are looping we will collect the seen row indicies, Rws()
' ' ddddddddddddddddddddddd Dictionaray bit ------
' Dictionaray - The only reason to use this is that its a convenient way to get a unique list thing, or a unique set of things.
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary") ' https://excelmacromastery.com/vba-dictionary/
'Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
Dim aTp() As Variant: ReDim aTp(1 To 3) ' This is a temporary array used to fill the dictionary Items it must be dynamic and variant type - see note +++ below
For Each cel In Rng_v ' we effectivelly are going down all the seen rows
If cel.Row > 1 And cel.Value <> "" Then
Let Rw = cel.Row
If Not Dik.exists(a(Rw, 2)) Then ' -Case we don't yet have any dictionaray item with this ID key
Let aTp(1) = Rw ' row number
Let aTp(2) = a(Rw, 35) ' grangtotal for this row
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' Our column Sums
Dik.Add Key:=a(Rw, 2), Item:=aTp() ' The key becomes the ID , The Item is a three element array of the row number the columns sum for this row the gradtotal for this row shothand way to do this line is d(a(r, 2)) = atp
Else ' ' -Case we already have a dictionary item with this key
Let aTp() = Dik.Item(a(Rw, 2)) ' we are returning an item that is an array, so the recieving array variable must be dynamic. the returned element type3s are Variant +++
If a(Rw, 35) > aTp(2) Then ' If the grand total for this row and ID is greater than a previous, then ....
Let aTp(1) = Rw ' we are replacing ..
Let aTp(2) = a(Rw, 35) ' .. the item with the relavent ..
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' .. info from this row
Dik(a(Rw, 2)) = aTp() ' shorthand version for Dik.Add Key:=a(Rw, 2), Item:=aTp()
End If
End If ' end of making or replacing a dictiuonary item
Else
End If
Next
' at this point we have a dictionary that has one Item for each ID
' in this last Dik bit we use the first and third part of the 3 element items in a pseudo arrOut()=AppIndex( arrUnjaggedJaged(), Rws() , Clms() ) ' https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
If Dik.Count Then
'Let JagdDikIt() = Application.Transpose(Dik.items()) ' we can treat an unjagged jagged array that is a 1 D array of 1 D arrays as if it was a 2 D array ... https://eileenslounge.com/viewtopic.php?p=266691#p266691
Let JagdDikIt() = Dik.items()
'Let Rws() = Application.Index(JagdDikIt(), 1, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let Rws() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 1) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
'Let aSum() = Application.Index(JagdDikIt(), 3, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let aSum() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 3) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
' ' ddddddddddddddddddddddddd -----------------------------
Else
End If
Else ' case only a header row to be seen
End If
End With
If Rng_v.Count = 1 Or Dik.Count = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Set Wrbk = Workbooks(Wnm)
If Wrbk Is Nothing Then
Workbooks.Open Filename:=Pth & Wnm
Else
Workbooks(Wnm).Activate
End If
On Error GoTo 0
With ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant ' just for demo purposes
Let vTemp = .UsedRange.Rows(1)
' { empty , Unique ID , Gap ,Name , Title , Platform , Salary , Gap, Total , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Formula7 , Formula8 , Formula9 }
Let vTemp = Rng.Rows(1)
' { Number , ID , Name , Title , Platform , Filter , , , , ,Salary , , , ,Add1 , Add2 , Add3 , Add4 , Add5 , Add6 , Add7 , Add8 , Add9 , Add10 , Add11 , Add12 , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Total , grandtotal }
Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 28 , error ,error ,error ,error ,error ,error ,error ,error ,error , }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , x ,x ,x ,x ,x ,x ,x ,x ,x , }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , 3 , 4 , 5 , 11 , 34, 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
With .Range("B2") ' .UsedRange.Offset(1)
' .Resize(, 15).ClearContents
Let arrOut__() = Application.Index(a(), Rws(), cls_v())
.Resize(UBound(Rws()), 1) = arrOut__()
Let Rws() = Evaluate("row(1:" & UBound(Rws()) & ")") ' Using the variable Rws() for a sequential indicie list 1; 2; 3 ... etc for all rows in the arrOut__()
.Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5)) ' columns D - G
.Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum() ' columm I
.Offset(, 8).Cells(1).Resize(UBound(Rws()), 7).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12)) ' Column J to P
End With
End With
' .Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
' Set cel = Nothing
Set Dik = Nothing
End Sub

DocAElstein

01-24-2021, 07:33 PM

ycb<ybc,bc,ybcybyb

DocAElstein

01-24-2021, 07:33 PM

In support of this posting
https://eileenslounge.com/viewtopic.php?p=280747#p280747

befores
_____ Workbook: Workbook2_2b.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAA
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7From SHEET2SalaryTotalcopy1copy2copy3copy4copy5copy6cop y7

2

3

4

5

6

7

8

9

10

11
Worksheet: Destination

DocAElstein

01-24-2021, 07:33 PM

In support of this posting
https://eileenslounge.com/viewtopic.php?p=280747#p280747

_____ Workbook: Transfer data_marasAlan_2b.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAG
1NumberUnique IDNameTitlePlatformFilterSalaryAdd1Add2Add3Add4Add 5Add6Add7Add8Add9Add10Add11Add12copy1copy2copy3cop y4copy5copy6copy7

21123RamManagerJavaFilter2£400355123222

9126SomOperatorCFilter2£1501,013

102354SaiOperatorC++Filter2£150232241,126

172563ViduManagerJavaFilter2£400812147

183239JackLeadSQLFilter2£300454484149

194222AndyOperatorJavaFilter2£1504148151

242333FranOperatorSQLFilter2£15011161

2533658LaluLeadCFilter2£3006666112163
Worksheet: Sheet1

DocAElstein

01-24-2021, 07:33 PM

In support of this posting
https://eileenslounge.com/viewtopic.php?p=280747#p280747

The after

_____ Workbook: Workbook2_2b.xlsx ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLMNOPQRSTUVWXYZAA
1Unique IDGapNameTitlePlatformSalaryGapTotalcopy1copy2copy 3copy4copy5copy6copy7From SHEET2SalaryTotalcopy1copy2copy3copy4copy5copy6cop y7

2123RamManagerJava£40058123222

326SomOperatorC£15001,013

4354SaiOperatorC++£15025241,126

5563ViduManagerJava£4000812147

6239JackLeadSQL£300454484149

7222AndyOperatorJava£15004148151

8333FranOperatorSQL£1502161

93658LaluLeadC£30024112163

10

11
Worksheet: Destination

DocAElstein

01-24-2021, 07:33 PM

Macro for last 3 posts

Option Explicit
Sub Transfer_Sht1After() ' https://eileenslounge.com/viewtopic.php?p=280747#p280747
Rem 1 Source Worksheets info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim Lr1 As Long: Let Lr1 = Ws1.Range("B" & Ws1.Rows.Count & "").End(xlUp).Row
'1b) Any column in the visible data is taken in the next code line, the main reason being as we need to get the row indicie info
Dim Rng_v As Range: Set Rng_v = Ws1.Range("B1:B" & Lr1 & "").SpecialCells(xlCellTypeVisible) ' this gets just the range we see, so will be likely a range of lots of areas
If Rng_v.Count = 1 Then ' case only header range visible
MsgBox Prompt:="No rows to transfer.": Exit Sub
Else ' there are visible rows to transfer
Rem 2 building a single column array for the summed colums, and the wanted visible row indicies from the main range
Dim aSum() As Variant: ReDim aSum(1 To Rng_v.Count - 1, 1 To 1) ' This will be a column array when applied to a worksheet
Dim Rws() As Long: ReDim Rws(1 To Rng_v.Count - 1, 1 To 1) ' we need a "virtical" array containing the "seen" row indicies
Dim Cel As Range
For Each Cel In Rng_v ' These are the cells in the multi Area range of visible cells
If Cel.Row > 1 And Cel.Value <> "" Then
Dim I As Long
Let I = I + 1
Let aSum(I, 1) = Evaluate("=Sum('[" & ThisWorkbook.Name & "]Sheet1'!O" & Cel.Row & ":'[" & ThisWorkbook.Name & "]Sheet1'!Z" & Cel.Row & ")")
Let Rws(I, 1) = Cel.Row ' This puts the visible rows indicie in our array indicationg the rows we need from the worksheet
Else
End If
Next Cel
End If
' Destination workbook and worksheet
Dim Pth As String: Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const Pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const Wnm = "Workbook2_2b.xlsx" 'your destination workbook2 name
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Dim WbDest As Workbook
Set WbDest = Workbooks(Wnm) ' will error if workbook is not yet open
If Err.Number > 0 Then
Workbooks.Open Filename:=Pth & Wnm ' we test to see if we have an error and if we do themn we kknow to open the workbook On Error GoTo 0
Set WbDest = ActiveWorkbook
Else
End If
''2a) Column indicies of the columns wanted from the data worksheet
Dim Clms() As Variant: Let Clms() = Array(2, 34, 3, 4, 5, 11, 34, 34, 27, 28, 29, 30, 31, 32, 33)
'2b) Typical arrOut()=AppIndex(arrIn(), Rws(), Clms())
Let WbDest.Worksheets.Item(1).Range("B2").Resize(UBound(Rws(), 1), 15).Value2 = Application.Index(Ws1.Cells, Rws(), Clms())
'2c)(ii) Sums column
Let WbDest.Worksheets.Item(1).Range("B2").Resize(UBound(Rws(), 1), 1).Offset(0, 7).Value2 = aSum()
End Sub

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

ahdlaKHDLakhdalkhd

DocAElstein

01-24-2021, 07:33 PM

Links hcDHADLHADHAD

DocAElstein

01-24-2021, 07:33 PM

AKHDalkhd

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

ADLAdlAHDLAhdlakHDLadh

DocAElstein

01-24-2021, 07:33 PM

hfhwhfhfhfashfh

15328

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 postsLKADHladhlAHAlhdaLDH

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 postslshfshfhfshslfhlkfhlh

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

ADHLhdlhd

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

01-24-2021, 07:33 PM

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1
TEST-1

2Name of the Student :
Rizwana

3Reg. No. :
256

4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS

2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks

3
01Rukhsar banu
256
X
2

4
02Abdulkhadar
123
X
3

5
03Rizwana
256
X
4

6
04Rizwana
256
X
4

7
05Rizwana
256
X
4
Worksheet: Result

15283

DocAElstein

01-24-2021, 07:33 PM

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1
TEST-1

2Name of the Student :
Rizwana

3Reg. No. :
256

4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS

2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks

3
01Rukhsar banu
256
X
2

4
02Abdulkhadar
123
X
3

5
03Rizwana
256
X
4

6
04Rizwana
256
X
4

7
05Rizwana
256
X
4
Worksheet: Result

DocAElstein

01-24-2021, 07:33 PM

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1
TEST-1

2Name of the Student :
Rizwana

3Reg. No. :
256

4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS

2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks

3
01Rukhsar banu
256
X
2

4
02Abdulkhadar
123
X
3

5
03Rizwana
256
X
4

6
04Rizwana
256
X
4

7
05Rizwana
256
X
4
Worksheet: Result

DocAElstein

01-24-2021, 07:33 PM

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1
TEST-1

2Name of the Student :
Rizwana

3Reg. No. :
256

4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS

2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks

3
01Rukhsar banu
256
X
2

4
02Abdulkhadar
123
X
3

5
03Rizwana
256
X
4

6
04Rizwana
256
X
4

7
05Rizwana
256
X
4
Worksheet: Result

DocAElstein

01-24-2021, 07:33 PM

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1
TEST-1

2Name of the Student :
Rizwana

3Reg. No. :
256

4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS

2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks

3
01Rukhsar banu
256
X
2

4
02Abdulkhadar
123
X
3

5
03Rizwana
256
X
4

6
04Rizwana
256
X
4

7
05Rizwana
256
X
4
Worksheet: Result

DocAElstein

01-24-2021, 07:33 PM

In support of this post
https://excelfox.com/forum/showthread.php/2705-Display-a-message-if-already-saved-data?p=15230#post15230

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G
H

1
TEST-1

2Name of the Student :
Rizwana

3Reg. No. :
256

4Class
X
Worksheet: Test

If the value of D3 and D4 of Test Sheet is matches with column C & D of Result sheet then, display a message "You are already submitted the test paper and you have secured (D3 and D4 of Test sheet match with column E of Result Sheet) marks".

_____ Workbook: Test Paper.xlsb ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E

1
TEST-1 RESULT ANALYSIS

2
Sl. No.
Name of the Student
Reg. No.
Class
Obtained Marks

3
01Rukhsar banu
256
X
2

4
02Abdulkhadar
123
X
3

5
03Rizwana
256
X
4

6
04Rizwana
256
X
4

7
05Rizwana
256
X
4
Worksheet: Result

DocAElstein

01-24-2021, 07:33 PM

macro for last two posts

Option Explicit
Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624
Dim a(), cls_v() As String, Rws(), aSum(), arrOut__(), JagdDikIt()
Dim Rng As Range, Rng_v As Range, cel As Range
Dim Wrbk As Workbook, Rw As Long
Dim Pth As String
Let Pth = ThisWorkbook.Path & Application.PathSeparator ' Const pth = "C:\Users\L026936\Desktop\Excel\" '<---- use own path
Const Wnm = "Workbook2_3.xlsx" 'your workbook name
' Application.ScreenUpdating = False
Rem 1 the main data range from source
With ThisWorkbook.Sheets("Sheet1")
Set Rng = .Range("a1:ai" & 36 & "") ' main data range hard coded to 36 for testing and demonstration .UsedRange.Rows.Count)
Let a() = Rng.Value ' all data values in the source. This will end up in the tyopical arrOut()=AppIndex( a(), Rws(), Clms() )
Set Rng_v = Rng.Columns(2).SpecialCells(xlCellTypeVisible) ' this gives us the range we see , (it is likely as a collection of areas) in the ID column
If Rng_v.Count > 1 Then
Rem 2 Make the sums column array, aSum() , and while we are looping we will collect the seen row indicies, Rws()
' ' ddddddddddddddddddddddd Dictionaray bit ------
' Dictionaray - The only reason to use this is that its a convenient way to get a unique list thing, or a unique set of things.
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary") ' https://excelmacromastery.com/vba-dictionary/
'Dim d As Scripting.Dictionary: Set d = New Scripting.Dictionary
Dim aTp() As Variant: ReDim aTp(1 To 3) ' This is a temporary array used to fill the dictionary Items it must be dynamic and variant type - see note +++ below
For Each cel In Rng_v ' we effectivelly are going down all the seen rows
If cel.Row > 1 And cel.Value <> "" Then
Let Rw = cel.Row
If Not Dik.exists(a(Rw, 2)) Then ' -Case we don't yet have any dictionaray item with this ID key
Let aTp(1) = Rw ' row number
Let aTp(2) = a(Rw, 35) ' grangtotal for this row
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' Our column Sums
Dik.Add Key:=a(Rw, 2), Item:=aTp() ' The key becomes the ID , The Item is a three element array of the row number the columns sum for this row the gradtotal for this row shothand way to do this line is d(a(r, 2)) = atp
Else ' ' -Case we already have a dictionary item with this key
Let aTp() = Dik.Item(a(Rw, 2)) ' we are returning an item that is an array, so the recieving array variable must be dynamic. the returned element type3s are Variant +++
If a(Rw, 35) > aTp(2) Then ' If the grand total for this row and ID is greater than a previous, then ....
Let aTp(1) = Rw ' we are replacing ..
Let aTp(2) = a(Rw, 35) ' .. the item with the relavent ..
Let aTp(3) = .Evaluate("=Sum(o" & Rw & ": z" & Rw & ")") ' .. info from this row
Dik(a(Rw, 2)) = aTp() ' shorthand version for Dik.Add Key:=a(Rw, 2), Item:=aTp()
End If
End If ' end of making or replacing a dictiuonary item
Else
End If
Next
' at this point we have a dictionary that has one Item for each ID
' in this last Dik bit we use the first and third part of the 3 element items in a pseudo arrOut()=AppIndex( arrUnjaggedJaged(), Rws() , Clms() ) ' https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
If Dik.Count Then
'Let JagdDikIt() = Application.Transpose(Dik.items()) ' we can treat an unjagged jagged array that is a 1 D array of 1 D arrays as if it was a 2 D array ... https://eileenslounge.com/viewtopic.php?p=266691#p266691
Let JagdDikIt() = Dik.items()
'Let Rws() = Application.Index(JagdDikIt(), 1, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let Rws() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 1) ' Application.Transpose(Application.Transpose(Applic ation.Index(v, 1, Evaluate("row(1:" & UBound(v, 2) & ")"))))
'Let aSum() = Application.Index(JagdDikIt(), 3, Evaluate("row(1:" & UBound(JagdDikIt(), 2) & ")")) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
Let aSum() = Application.Index(JagdDikIt(), Evaluate("row(1:" & UBound(JagdDikIt()) + 1 & ")"), 3) 'Application.Transpose(Application.Transpose(Appli cation.Index(v, 3, Evaluate("row(1:" & UBound(v, 2) & ")"))))
' ' ddddddddddddddddddddddddd -----------------------------
Else
End If
Else ' case only a header row to be seen
End If
End With
If Rng_v.Count = 1 Or Dik.Count = 0 Then
MsgBox "No rows to transfer."
Exit Sub
End If
On Error Resume Next ' https://eileenslounge.com/viewtopic.php?f=30&t=35861&start=20
Set Wrbk = Workbooks(Wnm)
If Wrbk Is Nothing Then
Workbooks.Open Filename:=Pth & Wnm
Else
Workbooks(Wnm).Activate
End If
On Error GoTo 0
With ActiveWorkbook
With .Sheets("Sheet1")
Dim vTemp As Variant ' just for demo purposes
Let vTemp = .UsedRange.Rows(1)
' { empty , Unique ID , Gap ,Name , Title , Platform , Salary , Gap, Total , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Formula7 , Formula8 , Formula9 }
Let vTemp = Rng.Rows(1)
' { Number , ID , Name , Title , Platform , Filter , , , , ,Salary , , , ,Add1 , Add2 , Add3 , Add4 , Add5 , Add6 , Add7 , Add8 , Add9 , Add10 , Add11 , Add12 , copy1 , copy2 , copy3 , copy4 , copy5 , copy6 , copy7 , Total , grandtotal }
Let vTemp = Application.Match(.UsedRange.Rows(1), Rng.Rows(1), 0) ' This gives a 1 D array and each element has either the position of the header in the destination workbook, or an error if it did not find it
' { 2 , error , 3 , 4 , 5 , 11 , error , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , 28 , error ,error ,error ,error ,error ,error ,error ,error ,error , }
' So the above line tells us where there is an error in a match with the header names
Let vTemp = Application.IfError(vTemp, "x") ' Instead of the vbError , a text of "x" is put into the array
' { 2 , x , 3 , 4 , 5 , 11 , x , 34 , 27 , 28 , 29 , 30 , 31 , 32 , 33 , x ,x ,x ,x ,x ,x ,x ,x ,x , }
Let vTemp = Filter(vTemp, "x", False, 0) ' take out the "x"s
' { 2 , 3 , 4 , 5 , 11 , 34, 27 , 28 , 29 , 30 , 31 , 32 , 33 }
Let cls_v() = Filter(Application.IfError(Application.Match(.Used Range.Rows(1), Rng.Rows(1), 0), "x"), "x", False, 0)
' { 2 , 3 , 4 , 5 , 11 , 27 , 28 , 29 , 30 , 31 , 32 , 33 }
With .Range("B2") ' .UsedRange.Offset(1)
' .Resize(, 15).ClearContents
Let arrOut__() = Application.Index(a(), Rws(), cls_v())
.Resize(UBound(Rws()), 1) = arrOut__()
Let Rws() = Evaluate("row(1:" & UBound(Rws()) & ")") ' Using the variable Rws() for a sequential indicie list 1; 2; 3 ... etc for all rows in the arrOut__()
.Offset(, 2).Cells(1).Resize(UBound(Rws()), 4).Value = Application.Index(arrOut__(), Rws(), Array(2, 3, 4, 5)) ' columns D - G
.Offset(, 7).Cells(1).Resize(UBound(Rws())) = aSum() ' columm I
.Offset(, 8).Cells(1).Resize(UBound(Rws()), 7).Value = Application.Index(arrOut__(), Rws(), Array(6, 7, 8, 9, 10, 11, 12)) ' Column J to P
End With
End With
' .Save
End With
' Set Rng = Nothing
' Set Rng_v = Nothing
' Set cel = Nothing
Set Dik = Nothing
End Sub

DocAElstein

01-24-2021, 07:33 PM

Links relavent to the last 9 posts

' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5458446
' _ First i wanted to filter column G from workbook 1 to "Filter 2" and transfer only filter 2 data to workbook 2.
' _ Then transferring like i wanted to transfer column C (source) to column B (destination) , column D to D, Column L to Column G, etc.
' _ I wanted to sum from column P to colum AA and transfer those sum to destination at column H
' _ Then copy from column AB to AH and paste in I to O in destination

Sub Transfer_maras_1()

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15278&viewfull=1#post15278
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15279&viewfull=1#post15279

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15277&viewfull=1#post15277

Files
Transfer data_marasAlan_1.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_1.xlsx : https://app.box.com/s/3d9gmeb2nlyr4gg9q802kk5mjgze8cl5

_.________________________________________________ _________________________________________________

Sub Transfer_marasAlan_2() '

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15276&viewfull=1#post15276
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15273&viewfull=1#post15273

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15272&viewfull=1#post15272

Files
Transfer data_marasAlan_2.xlsm : https://app.box.com/s/749a78z2ku4m1s1tg3fvgs1z1ud4s325
Workbook2_2.xlsx : https://app.box.com/s/13yh30a77spsluauck3nif309pic8fuz

_.___________________________________________

Sub Transfer_marasAlan_3() ' https://www.excelforum.com/excel-programming-vba-macros/1338596-transferring-data.html#post5460624

Here is a before and after…
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15269&viewfull=1#post15269
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15270&viewfull=1#post15270

Macro
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15271

Files
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page42#post15233
Transfer data_marasAlan_3.xlsm : https://app.box.com/s/p8kf5vo8jesql3n47sd1bzgm57qdpwdv
Workbook2_3.xlsx : https://app.box.com/s/y3rwvhfk3bo1rp9t7cgbk8yz3krymh23

DocAElstein

02-09-2021, 10:52 PM

In suppot of this thread
https://excelfox.com/forum/showthread.php/2709-Order-multiple-texts-in-quot-row-cells-quot-in-columns?p=15292#post15292

Input data

_____ Workbook: VBA3.xls ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F

1Find word1Abc2wer#3smar4chris

2AP1kAP1k, 6-9| AP1k, 10-13

3ForComeForCome, 13-19

4

5DoubleDouble, 14-16 | Double, 14-16| Double, 14-16Double, 14-16| Double, 14-16Double, 14-16| Double, 14-16
Worksheet: inputA

Wanted Output

_____ Workbook: VBA3.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1Output

21Abc

32wer#AP1k, 6-9

42wer#AP1k, 10-13

52wer#Double, 14-16

62wer#Double, 14-16

72wer#Double, 14-16

83smarForCome, 13-19

93smarDouble, 14-16

103smarDouble, 14-16

114chrisDouble, 14-16

124chrisDouble, 14-16
Worksheet: OutputB

Results after running macro in next post

_____ Workbook: VBA3.xls ( Using Excel 2007 32 bit )
Row\Col
A
B

1

21Abc

32wer#AP1k, 6-9

42wer# AP1k, 10-13

52wer#Double, 14-16

62wer# Double, 14-16

72wer# Double, 14-16

83smarForCome, 13-19

93smarDouble, 14-16

103smar Double, 14-16

114chrisDouble, 14-16

124chris Double, 14-16
Worksheet: Output

DocAElstein

02-09-2021, 10:53 PM

Macro for last post

Option Explicit
Sub StartOffvbadumbarse()
Rem 1 Worksheets info
Dim WsIn As Worksheet, WsOut As Worksheet
Set WsIn = ThisWorkbook.Worksheets.Item(1): Set WsOut = ThisWorkbook.Worksheets.Item(2)
Dim arrIn() As Variant: Let arrIn() = WsIn.Range("B1:F5").Value2
Rem 2
'2b
Dim Clm As Long
For Clm = 1 To 5 Step 1
If arrIn(1, Clm) = "" Then
' Nothing to do for no header
Else
Dim Itms As String: Let Itms = arrIn(1, Clm)
Dim RwDta As Long
For RwDta = 2 To 5 Step 1
Dim strFndWd As String
If arrIn(RwDta, Clm) = "" Then
' no data
Else
If InStr(1, arrIn(RwDta, Clm), "|", vbBinaryCompare) > 0 Then ' we must have two or more datas seperatied by a |
Dim CelDts As Long
For CelDts = 0 To UBound(Split(arrIn(RwDta, Clm), "|", -1, vbBinaryCompare))
Let strFndWd = strFndWd & Split(arrIn(RwDta, Clm), "|", -1, vbBinaryCompare)(CelDts) & vbCr & vbLf
Next CelDts
Else ' case single data
Let strFndWd = strFndWd & arrIn(RwDta, Clm) & vbCr & vbLf ' effectively a single row is added for this data
End If
End If
Next RwDta
'2e we have been through the data, so time to see what we got and fill our two strings appropriately
Dim strOutA As String, strOutB As String
If strFndWd = "" Then ' case we had no data
Let strFndWd = strFndWd & vbCr & vbLf ' effectively adds an empty row
Let strOutA = strOutA & Itms & vbCr & vbLf ' a single row with header
Else ' we have data, so need do add some rows to strOutA ( strOutB effecively has all the rows determined by the number of vbCr & vbLf added
Dim RwCnt As Long: Let RwCnt = UBound(Split(strFndWd, vbCr & vbLf, -1, vbBinaryCompare)) + 1 - 1 ' The number of vbCr & vbLf gives us the number rows
For CelDts = 1 To RwCnt
Let strOutA = strOutA & Itms & vbCr & vbLf
Next CelDts
End If
End If
Let strOutB = strOutB & strFndWd
Let strFndWd = ""
Next Clm
' I can view my data in a message box or in the immediate window
MsgBox Prompt:=strOutA: Debug.Print strOutA
MsgBox Prompt:=strOutB: Debug.Print strOutB

Rem 3 outout
Dim arrOutA() As String: Let arrOutA() = Split(strOutA, vbCr & vbLf, -1, vbBinaryCompare) ' Excel has the convention of taking a 1D array as being "horizontal" for spreadsheet purposes, so will consider it as a row of data values if applied to a worksheet range
Dim arrOutB() As String: Let arrOutB() = Split(strOutB, vbCr & vbLf, -1, vbBinaryCompare)
' Let WsOut.Range("A2").Resize(UBound(arrOutA()), 1).Value = Application.Transpose(arrOutA())
Let WsOut.Range("A2").Resize(UBound(arrOutA()), 1).Value = Application.Index(arrOutA(), Evaluate("=row(1:" & UBound(arrOutA()) & ")/row(1:" & UBound(arrOutA()) & ")"), Evaluate("=row(1:" & UBound(arrOutA()) & ")"))
' Let WsOut.Range("B2").Resize(UBound(arrOutB()), 1).Value = Application.Transpose(arrOutB())
Let WsOut.Range("B2").Resize(UBound(arrOutB()), 1).Value = Application.Index(arrOutB(), Evaluate("=row(1:" & UBound(arrOutB()) & ")/row(1:" & UBound(arrOutB()) & ")"), Evaluate("=row(1:" & UBound(arrOutB()) & ")"))
End Sub

DocAElstein

02-27-2021, 06:17 PM

for later use

DocAElstein

02-27-2021, 06:18 PM

In support of this post
http://www.eileenslounge.com/viewtopic.php?p=281164#p281164

Sub On___Then____() ' http://www.eileenslounge.com/viewtopic.php?p=281164#p281164
' Going nowhere the first ____ evaluates to a number in range 0 or 2 , 3, 4 ..... 255 so I don't GoTo
On 0.2 GoTo NeverBeHere
On Err GoTo NeverBeHere
On TwitTwo GoTo NeverBeHere
On Nmber(255) GoTo NeverBeHere
On -0.5 GoTo NeverBeHere
On 255.49999 GoTo NeverBeHere

' Going somewhere the first ____ evaluates to 1 so I GoTo
On 1 GoTo 10
MsgBox prompt:="I am never here. You will never see this"
10 On 1.49999 GoTo 20
MsgBox prompt:="I am never here. You will never see this"
20 On Nmber(0.5001) GoTo 30
MsgBox prompt:="I am never here. You will never see this"
30 Exit Sub
'
NeverBeHere:
' I will never be here
MsgBox prompt:="I am never here. You will never see this"
End Sub
Function TwitTwo() As Double
Let TwitTwo = 2.1
End Function
Function Nmber(ByVal No As Double) As Double
Let Nmber = No
End Function

DocAElstein

03-05-2021, 05:17 PM

Post for later use

DocAElstein

03-05-2021, 05:17 PM

Some notes from this question:
http://www.eileenslounge.com/viewtopic.php?p=281312#p281312
Yasser Question.JPG

Question …
http://www.eileenslounge.com/viewtopic.php?f=30&t=36224
http://i.imgur.com/Ot6o46f.jpg
_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHITUV
1NameDatesHelperCheck DatesResultaaYasser Given

2aa2021-02-192021-02-192021-01-262021-01-262021-01-292021-01-29

3aa2021-01-262021-01-262021-01-272021-01-272021-01-302021-01-30

4aa2021-01-272021-01-272021-01-282021-01-282021-02-052021-02-05

5aa2021-01-282021-01-282021-01-29Missing2021-02-122021-02-12

6aa2021-01-312021-01-312021-01-30Missing

7aa2021-02-012021-02-012021-01-312021-01-31

8aa2021-02-022021-02-022021-02-012021-02-01

9aa2021-02-032021-02-032021-02-022021-02-02

10aa2021-02-042021-02-042021-02-032021-02-03

11aa2021-02-062021-02-062021-02-042021-02-04

12aa2021-02-072021-02-072021-02-05Missing

13aa2021-02-082021-02-082021-02-062021-02-06

14aa2021-02-092021-02-092021-02-072021-02-07

15aa2021-02-102021-02-102021-02-082021-02-08

16aa2021-02-112021-02-112021-02-092021-02-09

17aa2021-02-132021-02-132021-02-102021-02-10

18aa2021-02-142021-02-142021-02-112021-02-11

19aa2021-02-152021-02-152021-02-12Missing

20aa2021-02-162021-02-162021-02-132021-02-13

21aa2021-02-172021-02-172021-02-142021-02-14

22aa2021-02-182021-02-182021-02-152021-02-15

23aa2021-02-202021-02-202021-02-162021-02-16

24aa2021-02-212021-02-212021-02-172021-02-17

25aa2021-02-222021-02-222021-02-182021-02-18

26aa2021-02-232021-02-232021-02-192021-02-19

27aa2021-02-242021-02-242021-02-202021-02-20

28aa2021-02-252021-02-252021-02-212021-02-21

29bb2021-01-272021-01-272021-02-222021-02-22

30bb2021-01-282021-01-282021-02-232021-02-23

31bb2021-01-312021-01-312021-02-242021-02-24

32bb2021-02-012021-02-012021-02-252021-02-25

33bb2021-02-032021-02-03
Worksheet: Sheet1

DocAElstein

03-05-2021, 05:26 PM

Continued from last post: Some notes from this question:
http://www.eileenslounge.com/viewtopic.php?p=281312#p281312
Yasser Question.JPG https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15418&viewfull=1#post15418

Hans Solution. What’s he doing:

Rem 1 Make dictionary of Dictionaries2
There are two dictionary variables.
The first one contains all the unique name values from column A . So this is the unique names dictionary
We loop down to build that dictionary, and the solution is relying on a un unbroken sequential list of names, in other words no mixed up , but an order list like
Name1
Name1
Name1
Name2
Name2
..etc.
In that main loop , all the values, from column B are put in the Item ( which is itself a dictionary ) of each unique name in the unique names dictionary.
This is the clever line that does that. The line is done for each row in the data to be looked in ( column B )
Let dct1(rng1(r1, 1))(Int(rng1(r1, 2))) = 1
The 1 is arbitrary. What we are doing is like referring to ( trying to put 1 into ) the key of an item in the second dictionary that does not exist. When this is done, rather than error, the Scripting.Dictionary is programmed to make an item with that key.
The end result of all this is that we end up with a main dictionary that has a key for each unique name. The item for each name / Key has a second dictionary in it of all the Integer parts of the Date & time in column B. ( The dictionary will be seeing the basic Excel .Vaue2 of the date & time, so the Integer part will be just the date.
Here is a pseudo couple of code lines to demo that last bit

Dick1(Name1) ( 2021-02-19 ) = 1
Dick1(Name1) ( 2021-01-26 ) = 1

You see what’s going on is the following:
Dick1(Name1) will always return the same thing which is the Item in Dick1 with the Key of Name1
So Effectively those lines are pseudo

Dick2 ( 2021-02-19 ) = 1
Dick2 ( 2021-01-26 ) = 1

What those code lines try to do is put a 1 in the items of a Dick2 element that does not exist. As noted, the Scripting.Dictionary is programmed to make an item with that key rather than error if such an action is attempted.
So that is just a convenient way to make the second dictionaries – Note I said dictionaries

We end up with this:
Dick1 keys
http://i.imgur.com/zTWYpuy.jpg

Dick2KeysWichAreDicksInDick1Items.jpg
http://i.imgur.com/Jsd2kXS.jpg

These lines give me that from doing a Shift F9 on any variable
Shift F9 on vTemps for Watch Window.JPG http://i.imgur.com/Ms7HmG6.jpg

Rem 2
We have an Outer loop and an inner loop in it.
__The outer loop is done once for each unique name, so for each key of the main dictionary
____The inner loop goes down the entire F column Check dates and does a write out any missing dates, that is to say dates not in the dictionary that is the item for that unique name, key of the main dictionary

Hans macro

Option Explicit
Sub ListMissing() ' ' Hans http://www.eileenslounge.com/viewtopic.php?p=281312#p281312
Dim vTemp1, vTemp2 ' For development and debug
Dim wsh1 As Worksheet
Dim wsh2 As Worksheet
Dim rng1 As Variant
Dim rng2 As Variant
Dim m1 As Long
Dim m2 As Long
Dim r1 As Long
Dim r2 As Long
Dim r3 As Long
Dim dct1 As Object
Dim dcTemp2 As Object
Dim n As Variant
Set dct1 = CreateObject("Scripting.Dictionary")
Set wsh1 = Worksheets("Sheet1")
Let m1 = wsh1.Range("A" & wsh1.Rows.Count).End(xlUp).Row
Let rng1 = wsh1.Range("A2:B" & m1).Value
Rem 1 Make dictionary of Dictionaries
For r1 = 1 To UBound(rng1)
If Not dct1.Exists(rng1(r1, 1)) Then ' this gives us 3 elements in the dct1 that have like key aa and the item is an empty dictionary object
Set dcTemp2 = CreateObject("Scripting.Dictionary") ' This effectively clears the variable used temporarily
dct1.Add Key:=rng1(r1, 1), Item:=dcTemp2
End If
Let dct1(rng1(r1, 1))(Int(rng1(r1, 2))) = 1 ' the 1 is arbritrary, we effectively create a Key looking like aa 2021-02-19 in the second dictionary that is the item of the unique
Next r1
vTemp1 = dct1.keys() ' Dick1.JPG http://i.imgur.com/zTWYpuy.jpg
vTemp2 = dct1.items() ' Dick2KeysWichAreDicksInDick1Items.jpg http://i.imgur.com/Jsd2kXS.jpg
'
Let m2 = wsh1.Range("F" & wsh1.Rows.Count).End(xlUp).Row
Let rng2 = wsh1.Range("F2:F" & m2).Value
'
Set wsh2 = Worksheets("Sheet2Hans")
wsh2.Range("A2:B" & wsh2.Rows.Count).Clear

Rem 2 Go through checking for existance of an Item. For no existance , then that is missing data
Let r3 = 1
' The outer loop is done once for each unique name, so for each key of the main dictionary ===========
For Each n In dct1.keys ' this and next line make it For Each of .._
Set dcTemp2 = dct1(n) ' _.. the dictionries within each item of Dick1 In other words For Each Name
' -----------------------------------------------
' The inner loop goes down the entire F column Check dates and does a write out any missing dates, that is to say dates not in the dictionary that is the item for that unique name, key of the main dictionary
For r2 = 1 To UBound(rng2) ' Going down the entire F range
If Not dcTemp2.Exists(rng2(r2, 1)) Then
Let r3 = r3 + 1
Let wsh2.Range("A" & r3).Value = n ' n is the key, the unique name, in the main large dictionary
Let wsh2.Range("B" & r3).Value = rng2(r2, 1) ' This will be the missing entry
Else
End If
Next r2 ' ________________________________________

Next n ' ================================================== ============================================
End Sub

DocAElstein

03-05-2021, 10:51 PM

Some notes for this question:
http://www.eileenslounge.com/viewtopic.php?p=281291#p281291

For example, this bit …. using formulas like that
=IFERROR(INDEX($A$2:$C$1000,MATCH(1,($A$2:$A$1000= $I$1)*($C$2:$C$1000=F2),0),3),"Missing")
Then I manually filter by Missing and copied the results…..
That can be done in a single code line, …. _

Sub BasicOneLine() ' '.... http://www.eileenslounge.com/viewtopic.php?p=281291#p281291
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace(Join(Appli cation.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")")), 1), 1), 1).Value = _
Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace(Join(Appli cation.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")")), 1)
End Sub

Before
_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )
Row\ColITUV
1aaYasser Given

22021-01-29

32021-01-30

42021-02-05

52021-02-12

6
Worksheet: Sheet1

After
_____ Workbook: Extract missing dates for each person.xlsm ( Using Excel 2007 32 bit )
Row\ColITUV
1aaYasser Given

22021-01-292021-01-29

32021-01-302021-01-30

42021-02-052021-02-05

52021-02-122021-02-12

6
Worksheet: Sheet1

Run Sub BasicOneLine() on the uploaded file to demo those results

DocAElstein

03-05-2021, 11:11 PM

extended coding notes for last post
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15420&viewfull=1#post15420

Sub Pretty2() '
Dim arrTemp() As Variant
Rem To get the results in column T ( same as
' Ths first forumula give me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' The next few lines get rid of the 0s
Dim StrTemp As String: Let StrTemp = Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare): StrTemp = Replace(StrTemp, "0#", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

' Or

Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace(Join(Appli cation.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")")), 1), 1), 1).Value = _
Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace(Join(Appli cation.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace(Join(Application.Inde x(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", ""), "#", -1)) + 1 & ")")), 1)

Stop

' Replace(Replace(Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), "0#", "")

Rem To get to Column N in Extract missing dates for each person.xlsm
' Ths first forumula give me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' The next step is to replace the errors with 0s
Let arrTemp() = Evaluate("=IFERROR(IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$ 2:$A$1000=$I$1),0)),0)") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' The next few lines get rid of the 0s
'Dim StrTemp As String
Let StrTemp = Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
'Dim arrStrTemp() As String
Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Range("C2:C463"), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match
Let Range("N2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("N2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

' Or

' Let arrTemp() = Evaluate("=If({1},IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$ 1000=$I$1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0) )")

'let worksheets("Sheet2").range
'v = Join(v, "#") ' https://www.vbarchiv.net/commands/cmd_filter.html
'
'
'v = Application.Index(Range("C2:C463"), Evaluate("=If({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0)*($A$2:$A$1000=$I$1))"), 1)
'
'
'v = Application.Index(v, Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
'v = Evaluate("=IFERROR(INDEX($A$2:$C$1000,MATCH(1,($A$2:$A$1000= $I$1)*($C$2:$C$1000=" & r.Address & "),0),3),""Missing"")")
'
End Sub
Sub BasicOneLine() ' '.... http://www.eileenslounge.com/viewtopic.php?p=281291#p281291

DocAElstein

03-06-2021, 12:47 AM

This is a slightly more sane version of the single line macro idea from here
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15420&viewfull=1#post15420
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15421&viewfull=1#post15421

Sub SlightlySanerVersion()
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Replace(Replace(Join(Application.Index(Evalu ate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "0#", ""), "#0", ""), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
' Or
Dim UnicNm As String: Let UnicNm = "aa"
Let arrStrTemp() = Split(Replace(Replace(Join(Application.Index(Evalu ate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & UnicNm & """" & "),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "0#", ""), "#0", ""), "#")
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
End Sub

We can use the basic idea above to make a function idea to do the same

Sub UseNotSoInsaneFunction()
Dim arrTemp() As Variant
Let arrTemp() = NotSoInsane("aa")
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
End Sub

Function NotSoInsane(ByVal Nme As String) As Variant
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Replace(Replace(Join(Application.Index(Evalu ate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & Nme & """" & "),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "0#", ""), "#0", ""), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let NotSoInsane = arrTemp()
End Function

DocAElstein

03-06-2021, 02:23 PM

In support of these Threads and posts
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15421&viewfull=1#post15421
http://www.eileenslounge.com/viewtopic.php?f=30&t=36224

A problem arose with testing with bb

_____ Workbook: Extract missing dates for each person bb.xlsm ( Using Excel 2007 32 bit )
Row\ColTUVWXYZ
1Yasser GivenHans ResultsIndicies

22021-01-262021-01-292021-01-292

32021-01-302021-01-300

42021-02-052021-02-050

52021-01-292021-02-122021-02-125

62021-01-302021-01-262021-01-266

72021-01-292021-01-290

82021-01-302021-01-300

92021-02-022021-02-022021-02-029

102021-02-050

112021-02-120

122021-02-052021-02-0512

132021-02-160

142021-02-190

152021-02-250

160

170

180

192021-02-122021-02-1219

202021-02-1320

210

222021-02-1522

232021-02-162021-02-1623

240

250

262021-02-192021-02-1926

270

280

290

300

310

322021-02-252021-02-2532

332021-01-290
Worksheet: Sheet1

If you examine above my ( wrong) results in column T against Hans results in column V and
then look at the Debug / Immediate window info below for
before ( http://i.imgur.com/M3laahV.jpg )
and
after ( http://i.imgur.com/RUPIWIg.jpg ), where I take out the unwanted data from a text string , .._

? strtemp
2#0#0#5#6#0#0#9#0#0#12#0#0#0#0#0#0#19#20#0#22#23#0 #0#26#0#0#0#0#0#32#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0 #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0

? strtemp
2#5#6#9#12#19#222#23#26#32
_...then I can see the problem and where its coming from:

The problem is that I chose to remove the unwanted data
_ first by removing all #0 - that works fine, no problem with that as I am not expecting any real data starting with a 0
_ second I allow for the case of unwanted data at the start by removing all 0# - this can cause problems as it has in this example – It has resulted for example in this
#20#0#22
becoming this
#20#22
And then when after , (or previously) the 0# is removed/ was removed, the final result is
#222
So I loose the valid data of 20 and 22 and get a wrong data of 222 ( and in the test data, indicial 222 matches to an empty cell )
The final outcome is I loose two final date values and gain an extra unwanted empty ( nonsense date zero value ) date

There are thousands of easy ways to solve this problem , with various If Then ways. But these will “interrupt the flow” as it were, leading to inefficiency and prevent me building my final one line code way.

This first element problem is one I often refer to as an awkward bollock
Variations of this come up a lot. Often an efficient cure to this awkward bollock is to include an extra separator at the start. This wont quite for us in the case of this data, but almost.
The following variation seems OK
Consider these two lines, where the awkward bollock is dealt with second

' The next few lines get rid of the 0s
Dim StrTemp As String: Let StrTemp = Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "#0", "", 2, -1, vbBinaryCompare): StrTemp = Replace(StrTemp, "0#", "", 1, -1, vbBinaryCompare) ' This effectively removes the 0s data ( and its seperator )
Solution:
I add some arbitrary character at the start
StrTemp = "_" & Join(arrTemp(), "#")
That wont add much extra overhead
Now deal with the awkward bollock first
StrTemp = Replace(StrTemp, "_0#", "_" ………..
That has done no extra work, just done an existing step a bit differently

So far nothing so clever. The next part allows us to do no, or little, extra work by taking advantage of a little known extra argument of the Replace
The forth (optional) argument of Replace lets us say at which character point in the original we start our returned string. That may confuse, so let me say that again with an example..
I have this xy-z-2 and I want this yz2
Most people would think they need
either
_ two Replaces , one to take out – and the other to take out x
or
_ a Replace to take out – and then some other process or function to take out the first character.

But if we choose 2 in our forth argument of the Replace that takes out the - , then our returned string will effectively have the first character removed.

' The next few lines get rid of the 0s
Dim StrTemp As String: Let StrTemp = "_" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "_0#", "_", 1, 1, vbBinaryCompare): StrTemp = Replace(StrTemp, "#0", "", 2, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )

That seems to solve the problem
strTempAfterProblemSolved.JPG
http://i.imgur.com/Dgu8NE1.jpg

Full macro in next post

DocAElstein

03-06-2021, 05:11 PM

Full macro for last post

Sub Pretty3bbProbSolved() ' https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15426&viewfull=1#post15426
Dim arrTemp() As Variant
Rem To get the results in column T ( same as
' Ths first forumula give me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' Or
Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))

' The next few lines get rid of the 0s
Dim StrTemp As String: Let StrTemp = "_" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data
Let StrTemp = Replace(StrTemp, "_0#", "_", 1, 1, vbBinaryCompare): StrTemp = Replace(StrTemp, "#0", "", 2, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or
Let arrStrTemp() = Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#")
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

' Or
Let arrStrTemp() = Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#")
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
' Or
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")")), 1), 1), 1).Value = _
Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1), Evaluate("=row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")/row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), _
Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")"), Evaluate("=row(1:" & UBound(Split(Replace(Replace("_" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "_0#", "_"), "#0", "", 2), "#", -1)) + 1 & ")")), 1)

End Sub

DocAElstein

03-06-2021, 07:02 PM

I am not quite sure what got in my brain in the last post. With hind site most of what I said and done is crap. But maybe later I will twig to what was going on.

I will start again…. Or rather pick it up where I went off course…._ I have …_
_.... an awkward bollock
Variations of this come up a lot. Often an efficient cure to this awkward bollock is to include an extra separator at the start.

The general solution is fine. After adding a separator, #, at the start, I remove all #0
All is well and then I only need to get rid finally of a single # I don’t need at the start.
For that last thing, Mid(StrTemp,2) would do. So would a second Replace in this form Replace(StrTemp, "#", "", 1, 1…. Or Replace(StrTemp, "#", "", , 1….
In the Replace.. we are using the 5th (optional ) argument to restrict us to removing a single # and the convention is to start from the left so that will hit on the first.

In this complete version I use the Mid(StrTemp,2) way

Option Explicit
Sub Pretty3bbaa() '
Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or Hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' Or
Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))

' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
'
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

End Sub
Sub SlightlySanerVersion()
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
' Or
Dim UnicNm As String: Let UnicNm = "aa" ' "aa"
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & UnicNm & """" & "),0)*($A$2:$A$1000=" & """" & UnicNm & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
End Sub

DocAElstein

03-07-2021, 03:59 PM

I can sanitise the last version a bit and come up with a simple function to get you an array of your missings, where the function takes the unique name, ( the unique name in the test data is the things like aa bb cc etc. )

Sub SlightlySanerVersion()
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
' Or
Dim UnicNm As String: Let UnicNm = "aa" ' "aa"
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & UnicNm & """" & "),0)*($A$2:$A$1000=" & """" & UnicNm & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
End Sub
Sub UseNotSoInsaneFunction()
Dim arrTemp() As Variant
Let arrTemp() = NotSoInsane("bb")
' Columns("T:T").ClearContents ' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub
Function NotSoInsane(ByVal Nme As String) As Variant
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & Nme & """" & "),0)*($A$2:$A$1000=" & """" & Nme & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let NotSoInsane = arrTemp()
End Function
'

DocAElstein

03-07-2021, 04:23 PM

Post for later use

DocAElstein

03-07-2021, 04:24 PM

If I use a Transpose function at one place instead of my preferred Index way of transposing things, then I can reduce it to a single code line: This for example will get your pasted results for the unique “aa” Missings

Sub SingleLineWithTranspose()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
End Sub

Here are some of the full workings used to get that single code line:

Sub Pretty3bbaaTranspose() '
Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F463,C2:C463,0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I$1), 0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F463=0,0,MATCH(F2:F463,C2:C463*($A$2:$A$100 0=$I$1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))
' Or
Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)"))

' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")

' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Transpose(arrStrTemp())
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(arrStrTemp()), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)

Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

End Sub
Sub SingleLineWithTranspose()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=$I $1),0)*($A$2:$A$1000=$I$1)),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")), 1)
End Sub

DocAElstein

03-07-2021, 05:46 PM

post for latzer use

View North from Balcony .. a castle I don’t know the name of on the Horizon, ( the hook is part of the Father in Laws new elevator to lift up shopping etc to the Third floor
02_BalconyNorthAnotherCastleAndHookFromFatherInLaw sMotorisedLift.jpg : https://imgur.com/ZG6Dmg2

View South from Balcony – the famous Coburg Veste
03_BalconySouthVeste.jpg : https://imgur.com/uNnCO8F

View East from Balcony - Bavarian fairy land
06_PrettyViewEast.jpg : https://imgur.com/1DzYrL2

Beer Mugs: I don’t drink much, certainly not at home, and never when building. But with the Father in Law it has become a bit of a tradition .. a German beer or two.
04_CoburgBalconyBeerMugs.jpg : https://imgur.com/RDXq3HH

Our old Blue bus hidden in a back lane: View of the Veste from guest room, and at the bottom our old blue VW bus – we have to hide it as it does not fit in too well
05_GuestRoomCoburgVesteAndBlueVWBus.jpg : https://imgur.com/30B3nkp

A very bad picture or the Veste at night from the parents in law’s living room … Bavarian “Fairy land” – what a view to have..
08_VesteAtNight.jpg : https://imgur.com/5HrY1Hy

Finally, that ugly man spoiling the view again..
07_UglyManInPicture : https://imgur.com/Eic7NSD

View North from Balcony .. a castle I don’t know the name of on the Horizon, ( the hook is part of the Father in Laws new elevator to lift up shopping etc to the Third floor
02_BalconyNorthAnotherCastleAndHookFromFatherInLaw sMotorisedLift.jpg : http://i.imgur.com/ZG6Dmg2.jpg

View South from Balcony – the famous Coburg Veste
03_BalconySouthVeste.jpg : http://i.imgur.com/uNnCO8F.jpg

View East from Balcony - Bavarian fairy land
06_PrettyViewEast.jpg : http://i.imgur.com/1DzYrL2.jpg

Beer Mugs: I don’t drink much, certainly not at home, and never when building. But with the Father in Law it has become a bit of a tradition .. a German beer or two.
04_CoburgBalconyBeerMugs.jpg : http://i.imgur.com/RDXq3HH.jpg

Our old Blue bus hidden in a back lane: View of the Veste from guest room, and at the bottom our old blue VW bus – we have to hide it as it does not fit in too well
05_GuestRoomCoburgVesteAndBlueVWBus.jpg : http://i.imgur.com/30B3nkp.jpg

A very bad picture or the Veste at night from the parents in law’s living room … Bavarian “Fairy land” – what a view to have..
08_VesteAtNight.jpg : http://i.imgur.com/5HrY1Hy.jpg

Finally, that ugly man spoiling the view again..
07_UglyManInPicture : http://i.imgur.com/Eic7NSD.jpg

DocAElstein

03-07-2021, 05:47 PM

In support of these post
https://eileenslounge.com/viewtopic.php?p=281384#p281384
https://eileenslounge.com/viewtopic.php?p=281383#p281383

Finally, If I use a simple Dictionary way to get your unique names from your column A, then I can incorporate my ideas into a full solution that gets the same results as Hans using your uploaded test data.
Rem 1 Gets your unique names from column A
Rem 2 Loops through those unique names and each time in the loop the Function is called to get an array of your missings.

Sub EvaluateRangeFormulaWay() ' http://www.eileenslounge.com/viewtopic.php?p=281315#p281315
Rem 0 worksheets info
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1"): Set Ws2 = ThisWorkbook.Worksheets.Item("Sheet2Alan")
Dim Em1 As Long: Let Em1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA1() As Variant: Let arrA1() = Ws1.Range("A1:A" & Em1 & "").Value2 ' All names list
Rem 1
Dim Dik1 As Object: Set Dik1 = CreateObject("Scripting.Dictionary")
' 1b) make list of unique names
Dim Cnt
For Cnt = 2 To Em1 ' Looping down all names
Let Dik1(arrA1(Cnt, 1)) = "This can be anything you like, it don't really matter. What happens here is that we try to put this text in the Item of a dictionary entry that has the key of the value of arrA1(Cnt, 1) If that entry does not exist, then the dictionary is programmed not to error , but instead make ( Add ) an entry with that key value. For our purposes we don't care what the items are. But at the end of this loop we will have effectively Added a element in the dictionary, one for each of the unique name values. We can then use the Keys() array as a convenient way to get an array of unique names"
Next Cnt
Dim arrUnics() As Variant: Let arrUnics() = Dik1.Keys() ' This is an array of our unique Names
Rem 2 Do it
Dim R3Lne As Long: Let R3Lne = 2 ' This is the next free line in second worksheet
For Cnt = 0 To UBound(arrUnics()) ' looping through all uniques names
Dim arrMisins() As Variant: Let arrMisins() = Missings(arrUnics(Cnt)) '## Go to the function that makes an array of the Missing dates based on the Name value
Dim NoMisins As Long: Let NoMisins = UBound(arrMisins(), 1)
Let Ws2.Range("A" & R3Lne & ":A" & R3Lne + (NoMisins - 1) & "").Value = arrUnics(Cnt) ' Put the name in as many cells as we have missing dates
Let Ws2.Range("B" & R3Lne & ":B" & R3Lne + (NoMisins - 1) & "").Value = arrMisins() ' Put the missing dates in
Let R3Lne = R3Lne + NoMisins ' This is the next free line in second worksheet
Next Cnt

Let Ws2.Range("B2:B" & Ws2.UsedRange.Rows.Count + 1 & "").NumberFormat = "yyyy/mm/dd"
End Sub
Function Missings(ByVal Nme As String) As Variant
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Worksheets("Sheet1").Evaluate("=IF(ISERROR(MATCH(F2:F463,C2:C463*($A$2:$A$1000=" & """" & Nme & """" & "),0)*($A$2:$A$1000=" & """" & Nme & """" & ")),ROW(F2:F463),0)"), Evaluate("=column(A:QT)"), Evaluate("=column(A:QT)/column(A:QT)")), "#"), "#0", ""), 2), "#")
Dim arrTemp() As Variant: Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
Let Missings = arrTemp()
End Function

Sub TestFunctionMissings()
Dim arrTemp() As Variant
Let arrTemp() = Missings("bb")
' Columns("T:T").ClearContents ' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub

DocAElstein

03-07-2021, 05:49 PM

I have done another couple of versions, just out of interest.

I have also adjusted the code to be the same last row, but in these two versions the last row is not hard coded. I am using the last row of data. So that is found dynamically in the usual way.

Because we use the same last row, I can simplify a few things.

The difference between the two new versions is that
_ one uses the conventional Transpose function to do a couple of transposing.
_ In the other one, the same transposing is done in that strange Index function way that I personally like to do.

Index Function Way

' Using the Index way for the tranposing
Sub Pretty3d() '
Rem 0 worksheets info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1")
Dim M As Long: Let M = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row

Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or Hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F" & M & ",Int(B2:B" & M & "),0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F" & M & ",Int(B2:B" & M & ")*($A$2:$A$1000=$I$1),0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F" & M & "=0,0,MATCH(F2:F" & M & ",C2:C" & M & "*(A2:A" & M & "=I1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction whuch annoyingly onl work on 1 D arrays, so we convert it by a transpose in the next code line
Let arrTemp() = Application.Index(arrTemp(), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")"))
' Or
' Let arrTemp() = Application.Transpose(arrTemp())

Let arrTemp() = Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")"))

' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
' We need a "vertical" array for output, so we transpose
Let arrTemp() = Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")"))

Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' or
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"
Stop
' Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

End Sub
Sub ShortPretty3d()
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
End Sub
Function ShortPretty3dFunction(ByVal Nme As String) As Variant
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Dim arrStrTemp() As String: Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Index(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=" & """" & Nme & """" & "),0)*(A2:A" & M & "=" & """" & Nme & """" & ")),ROW(F2:F" & M & "),0)"), Evaluate("=column(A:" & CL(M - 1) & ")"), Evaluate("=column(A:" & CL(M - 1) & ")/column(A:" & CL(M - 1) & ")")), "#"), "#0", ""), 2), "#")
Let ShortPretty3dFunction = Application.Index(Worksheets("Sheet1").Columns(6), Application.Index(arrStrTemp(), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")/row(1:" & UBound(arrStrTemp()) + 1 & ")"), Evaluate("=row(1:" & UBound(arrStrTemp()) + 1 & ")")), 1)
End Function
Sub TestShortPretty3dFunction()
Dim arrTemp() As Variant
Let arrTemp() = ShortPretty3dFunction("aa")
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub

see next post
Transpose Function Way

DocAElstein

03-08-2021, 12:53 AM

Transpose Function Way

' Using Transpose for the transposing
Sub Pretty3dTranspose() '
Rem 0 worksheets info
Dim Ws1 As Worksheet
Set Ws1 = ThisWorkbook.Worksheets.Item("Sheet1")
Dim M As Long: Let M = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row

Dim arrTemp() As Variant
Rem To get the results in column T ( same as Yassers or Hans Results
' Ths first forumula gives me all the matches for F in the C ( helper column ) or error for no match
Let arrTemp() = Evaluate("=If({1},MATCH(F2:F" & M & ",Int(B2:B" & M & "),0))") ' If({1},____) may not be needed for Excel 2016 and higher The first formula does the main work
' The multiplication by $A$2:$A$1000=$I$1 limits the range used by effectively making 0 check dates outside or range of interest
Let arrTemp() = Evaluate("=IF({1},MATCH(F2:F" & M & ",Int(B2:B" & M & ")*($A$2:$A$1000=$I$1),0))") ' $A$2:$A$1000=$I$1 gives us an array full of Falses and Trues , which Excel will interpret mathematically as 0 or 1 This has the effect of giving us a 0 multiplyer on numbers outside our range of interst, so in total a 0 for outside our range of interest. Our range of interest gets a 1 multiplier so has therefore no change and we can find those numbers whereas we wont find a 0, well actually we will find a zero if the range to search for has a zero as it does further down, so we take care of that in the next line
' The above formula has one problem with the supplied data in that empty cells are seen in this formula as 0 which gives a match
Let arrTemp() = Evaluate("=IF(F2:F" & M & "=0,0,MATCH(F2:F" & M & ",C2:C" & M & "*(A2:A" & M & "=I1),0))") ' In looking in the range to find a match in ( the range to be searched we have all 0s outside the range caused by the previous $A$2:$A$1000=$I$1 So the first of these 0s will be seen as the match cell for all cells in F that are empty. So i take care here of the situation where an empty cell in F is by giving a 0 output So far two things retrn me a zero. You often find in formula building that the coercing If({1},___) suddenly is not needed. Her we find that the newly used here IF(F2:F463=0,0,___) is doing the required co oecing
' we will now do a simple If(ISERROR( ) , Row( ) , 0 ) on the above . This will give us a row indicie for the missing data, and a 0 for the found data
Let arrTemp() = Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")
' At this point we have wanted data or zeros. I want to conveniently use some VB string fuction which annoyingly on work on 1 D arrays, so we convert it by a transpose in the next code line
'Let arrTemp() = Application.Transpose(arrTemp())
' Or
Let arrTemp() = Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)"))

' The next few lines get rid of the 0s ( 2 lines commented out to prevent the shortened line messing up )
Dim StrTemp As String: Let StrTemp = "#" & Join(arrTemp(), "#") ' Convert the array to a string with a # in between each data. The extra # allows us to remove all 0 entries via removing all #0 Without this we might get one left at the start
' Let StrTemp = Replace(StrTemp, "#0", "", 1, -1, vbBinaryCompare) ' This effectiveely removes the 0s data ( and its seperator )
' Let StrTemp = Mid(StrTemp, 2) ' Because I omit the third optional ( length ) argument I get all the remaing string after the first one. This effectively takes off the extra # which I don't need
Dim arrStrTemp() As String: Let arrStrTemp() = Split(StrTemp, "#", -1, vbBinaryCompare) ' remake the array
' Or ,
Let arrStrTemp() = Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")
' We need a "vertical" array for output, so we transpose to the original orientation, and I need a variant type for that regardless of if i use the in built Transpose way or my preferred Index way since both those will return elements in Variant type
Let arrTemp() = Application.Transpose(arrStrTemp())
' Or
Let arrTemp() = Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#"))
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), arrTemp(), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(arrStrTemp()), 1) ' finally we want the dates ( so far we have the row indicies obtained from Match Note. this formula has the problem that we get the results a row out of step... Its actually very convenient because if i use Cells typically, here a column then I have a nice solution
' Or
Let arrTemp() = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
' Or
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)

Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd" ' from macro recorder .NumberFormat = "[$-1010000]yyyy/mm/dd,@"

Stop
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents

End Sub
Sub SingleLinePretty3dTranspose()
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Let Range("T2").Resize(UBound(Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1), 1), 1).Value = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=I1),0)*(A2:A" & M & "=I1)),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)
End Sub

Function ShortPretty3dFunctionTranspose(ByVal Nme As String) As Variant
Dim M As Long: Let M = Worksheets("Sheet1").Range("A" & Worksheets("Sheet1").Rows.Count & "").End(xlUp).Row
Let ShortPretty3dFunctionTranspose = Application.Index(Worksheets("Sheet1").Columns(6), Application.Transpose(Split(Mid(Replace("#" & Join(Application.Transpose(Evaluate("=IF(ISERROR(MATCH(F2:F" & M & ",Int(B2:B" & M & ")*(A2:A" & M & "=" & """" & Nme & """" & "),0)*(A2:A" & M & "=" & """" & Nme & """" & ")),ROW(F2:F" & M & "),0)")), "#"), "#0", ""), 2), "#")), 1)
End Function
Sub TestShortPretty3dFunctionTranspose()
Dim arrTemp() As Variant
Let arrTemp() = ShortPretty3dFunctionTranspose("aa")
Range("T2").Resize(UBound(arrTemp(), 1), 1).ClearContents
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).Value = arrTemp()
Let Range("T2").Resize(UBound(arrTemp(), 1), 1).NumberFormat = "yyyy/mm/dd"
End Sub

DocAElstein

03-22-2021, 03:02 PM

Some extra solutions for this Thread
https://excelfox.com/forum/showthread.php/2738-PQ-make-new-column-by-extracting-a-word-from-a-cell-that-contains-a-sign

Excel Solution
_____ Workbook: TextWith$InIt.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLM
15465 Apples$50 Twenty =FIND("$",A1)=LEFT(A1,B1)=FIND(" ",C1)=RIGHT(C1,LEN(C1)-D1)=RIGHT(A1,LEN(A1)-B1)=FIND(" ",F1)=LEFT(F1,G1-1)=E1&H1=RIGHT(LEFT(A1,FIND("$",A1)),LEN(LEFT(A1,FIND("$",A1)))-FIND(" ",LEFT(A1,FIND("$",A1))))&LEFT(RIGHT(A1,LEN(A1)-FIND("$",A1)),FIND(" ",RIGHT(A1,LEN(A1)-FIND("$",A1)))-1)Apples$50Apples$50

25687 Grapes$597 Three =FIND("$",A2)=LEFT(A2,B2)=FIND(" ",C2)=RIGHT(C2,LEN(C2)-D2)=RIGHT(A2,LEN(A2)-B2)=FIND(" ",F2)=LEFT(F2,G2-1)=E2&H2=RIGHT(LEFT(A2,FIND("$",A2)),LEN(LEFT(A2,FIND("$",A2)))-FIND(" ",LEFT(A2,FIND("$",A2))))&LEFT(RIGHT(A2,LEN(A2)-FIND("$",A2)),FIND(" ",RIGHT(A2,LEN(A2)-FIND("$",A2)))-1)Grapes$597Grapes$597
Worksheet: Sheet2
_____ Workbook: TextWith$InIt.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLM
15465 Apples$50 Twenty 125465 Apples$5Apples$50 Twenty 350Apples$50Apples$50Apples$50Apples$50

25687 Grapes$597 Three 125687 Grapes$5Grapes$597 Three 4597Grapes$597Grapes$597Grapes$597Grapes$597
Worksheet: Sheet2

Some VBA Solutions

Option Explicit
' https://excelfox.com/forum/showthread.php/2738-PQ-make-new-column-by-extracting-a-word-from-a-cell-that-contains-a-sign https://www.mrexcel.com/board/threads/power-query-make-new-column-by-extracting-a-word-from-a-cell-that-contains-a-sign.1165642/
Sub Frm1a() '
Dim vTemp As Variant ' =RIGHT(LEFT(A1,FIND(""$"",A1)),LEN(LEFT(A1,FIND(""$"",A1)))-FIND("" "",LEFT(A1,FIND(""$"",A1))))&LEFT(RIGHT(A1,LEN(A1)-FIND(""$"",A1)),FIND("" "",RIGHT(A1,LEN(A1)-FIND(""$"",A1)))-1)
Let vTemp = Evaluate("=RIGHT(LEFT(A1,FIND(""$"",A1)),LEN(LEFT(A1,FIND(""$"",A1)))-FIND("" "",LEFT(A1,FIND(""$"",A1))))&LEFT(RIGHT(A1,LEN(A1)-FIND(""$"",A1)),FIND("" "",RIGHT(A1,LEN(A1)-FIND(""$"",A1)))-1)")
Debug.Print vTemp ' http://i.imgur.com/LARD8FB.jpg
Dim Rng As Range: Set Rng = Range("A1")
Let vTemp = Evaluate("=RIGHT(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")),LEN(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")))-FIND("" "",LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & "))))&LEFT(RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")),FIND("" "",RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")))-1)")
'Set Rng = Range("A1:A2")
' Let vTemp = Evaluate("=RIGHT(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")),LEN(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")))-FIND("" "",LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & "))))&LEFT(RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")),FIND("" "",RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")))-1)")
End Sub
Sub Frm1b()
Dim Rng As Range
For Each Rng In Range("A1:A2")
Let Rng.Offset(0, 11).Value = Evaluate("=RIGHT(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")),LEN(LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & ")))-FIND("" "",LEFT(" & Rng.Address & ",FIND(""$""," & Rng.Address & "))))&LEFT(RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")),FIND("" "",RIGHT(" & Rng.Address & ",LEN(" & Rng.Address & ")-FIND(""$""," & Rng.Address & ")))-1)")
Next Rng
End Sub
Sub Frm2a()
Dim Rng As Range
For Each Rng In Range("A1:A2")
Dim vTemp As Variant, vTemp1 As Variant, vTemp2 As Variant
Let vTemp = Split(Rng.Value, "$", -1, vbBinaryCompare)
Let vTemp2 = Left(vTemp(1), InStr(1, vTemp(1), " ", vbBinaryCompare) - 1)
Let vTemp1 = Split(vTemp(0), " ", -1, vbBinaryCompare)
Let vTemp1 = vTemp1(UBound(vTemp1))
Let vTemp = vTemp1 & "$" & vTemp2
Next Rng
End Sub
Sub Frm2b()
Dim Rng As Range
For Each Rng In Range("A1:A2")
Dim vTemp As Variant ' , vTemp1 As Variant, vTemp2 As Variant
Let vTemp = Split(Rng.Value, "$")
'Let vTemp2 = Left(vTemp(1), InStr(vTemp(1), " ") - 1)
'Let vTemp1 = Split(vTemp(0), " ")
'Let vTemp1 = Split(vTemp(0), " ")(UBound(Split(vTemp(0), " ")))
'Let vTemp = Split(vTemp(0), " ")(UBound(Split(vTemp(0), " "))) & "$" & Left(vTemp(1), InStr(vTemp(1), " ") - 1)
Let Rng.Offset(0, 12).Value = Split(vTemp(0), " ")(UBound(Split(vTemp(0), " "))) & "$" & Left(vTemp(1), InStr(vTemp(1), " ") - 1)
Next Rng
End Sub

DocAElstein

03-30-2021, 01:14 PM

Some note from following info from pconlife.com
Downloading some of their files
Info from here
All file info https://www.pconlife.com/fileinfo/winhlp32.exe-info/#howdownloadandusefile

I initially downloaded some of the zipped winhlp32.exe files, tried on several different computers to open/unzip them . None of the downloaded files will open or unzip. The error is always the same “ Invalid file” http://i.imgur.com/hthN74l.jpg
I followed their advice to try 7.zip , a free Open source program http://www.7-zip.org/

In the following posts I have the
_ downloaded zip file
_ The unzipped exe ( using 7.zip )
_ a re zipped in windows version of that unzipped exe

DocAElstein

03-31-2021, 12:46 PM

Windows XP Home Edition x32 Service Pack3:
5.1.2600.0 Download : https://www.pconlife.com/download/winosfile/1024/1/37b726c72699456bf34134c2bb89727a/

FileVersionFile Md5File SizeFile BitFile
5.1.2600.0 (XPClient.010817-1148) 37b726c72699456bf34134c2bb89727a 8K 32bit

unpacked files in the following path:
• • C:\Windows\system32\

_ Share ‘5 1 2600 0 WINHLP32 EXE.zip’ https://app.box.com/s/tkb7lz4hprmvp2bczwjyj59k2n1tl1h6
_ ** Share ‘5 1 2600 0 WINHLP32 EXE.exe’ https://app.box.com/s/fb0xyzjh7v7oo1bf8hv5r6r986pxeuod
_ Share ‘5 1 2600 0 WINHLP32 EXE Re Zip.zip’ https://app.box.com/s/m9a9huq67rd9pac923nbf3p48ajfmaed

5.1.2600.5512 Download :

FileVersionFile Md5File SizeFile BitFile
5.1.2600.5512 (xpsp.080413-0852) 65a9495a436f5402bc1c467e1b926c27 277K 32bit

unpacked files path:
• • C:\Windows\system32\dllcache\
• • C:\Windows\

_ Share ‘5 1 2600 5512 WINHLP32 EXE.zip’ https://app.box.com/s/tkb7lz4hprmvp2bczwjyj59k2n1tl1h6
_ ** Share ‘5 1 2600 5512 WINHLP32 EXE.exe’ https://app.box.com/s/rdrrs69mpimt2rh2usf5egr3yvadbizr
_ Share ‘5 1 2600 5512 WINHLP32 EXE Re Zip.zip’ https://app.box.com/s/3w2evt1rlq75j1rjfui6bx8qohmros9c

(** These are typical warnings that are shown after a 7.zip unzipping:
http://i.imgur.com/Zg2ZWAq.jpg
http://i.imgur.com/9r2rBVa.jpg 3553

Here are the final files that I have. I changed the names slightly to help distinguish between different winhlpexe files for different operating systems
http://i.imgur.com/HpEGeig.jpg
http://i.imgur.com/x00l1dj.jpg

DocAElstein

04-07-2021, 01:06 PM

In support of this Thread
https://www.eileenslounge.com/viewtopic.php?f=30&t=36380

Excel 2003

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
16764057 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
16763904 $D$34
16777215 $E$34
16763904 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
52377 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
52377 $D$37
16777215 $E$37
52377 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
52377 $F$38
16777215 $G$38
16777215 $H$38

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
16764057 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
16763904 $D$34
16777215 $E$34
16763904 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
52377 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
52377 $D$37
16777215 $E$37
52377 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
52377 $F$38
16777215 $G$38
16777215 $H$38

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
16764057 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
16763904 $D$34
16777215 $E$34
16763904 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
52377 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
52377 $D$37
16777215 $E$37
52377 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
52377 $F$38
16777215 $G$38
16777215 $H$38

The above .xls file in 2010

16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
****15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

DocAElstein

04-07-2021, 01:34 PM

in support of this Thread post
https://www.eileenslounge.com/viewtopic.php?p=282274#p282274

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
15261110 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

In one 2007 no interior color is shown ( there are errors in opening the .xlsb file ). For this same file saved as .xls I get in that 2007 this:

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
16777215 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
16777215 $D$34
16777215 $E$34
16777215 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
16777215 $D$35
16777215 $E$35
16777215 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
16777215 $D$36
16777215 $E$36
16777215 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
16777215 $D$37
16777215 $E$37
16777215 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
16777215 $D$38
16777215 $E$38
16777215 $F$38
16777215 $G$38
16777215 $H$38

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
15261110 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

The above Excel with the .xls file version

16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
15261110 $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

DocAElstein

04-07-2021, 01:38 PM

In support of this post
https://www.eileenslounge.com/viewtopic.php?p=282275#p282275

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
****15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
****15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

In the above 2010 the following is from a .xls version of the file

16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
****15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

DocAElstein

04-07-2021, 05:46 PM

From
https://eileenslounge.com/viewtopic.php?p=282284#p282284

16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
**** 15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20
16777215 $B$20
16777215 $C$20
16777215 $D$20
16777215 $E$20
16777215 $F$20
16777215 $G$20
16777215 $H$20
16777215 $A$21
16777215 $B$21
16777215 $C$21
16777215 $D$21
16777215 $E$21
16777215 $F$21
16777215 $G$21
16777215 $H$21
16777215 $A$22
16777215 $B$22
16777215 $C$22
16777215 $D$22
16777215 $E$22
16777215 $F$22
16777215 $G$22
16777215 $H$22
16777215 $A$23
16777215 $B$23
16777215 $C$23
16777215 $D$23
16777215 $E$23
16777215 $F$23
16777215 $G$23
16777215 $H$23
16777215 $A$24
16777215 $B$24
16777215 $C$24
16777215 $D$24
16777215 $E$24
16777215 $F$24
16777215 $G$24
16777215 $H$24
16777215 $A$25
16777215 $B$25
16777215 $C$25
16777215 $D$25
16777215 $E$25
16777215 $F$25
16777215 $G$25
16777215 $H$25
16777215 $A$26
16777215 $B$26
16777215 $C$26
16777215 $D$26
16777215 $E$26
16777215 $F$26
16777215 $G$26
16777215 $H$26
16777215 $A$27
16777215 $B$27
16777215 $C$27
16777215 $D$27
16777215 $E$27
16777215 $F$27
16777215 $G$27
16777215 $H$27
16777215 $A$28
16777215 $B$28
16777215 $C$28
16777215 $D$28
16777215 $E$28
16777215 $F$28
16777215 $G$28
16777215 $H$28
16777215 $A$29
16777215 $B$29
16777215 $C$29
16777215 $D$29
16777215 $E$29
16777215 $F$29
16777215 $G$29
16777215 $H$29
16777215 $A$30
16777215 $B$30
16777215 $C$30
16777215 $D$30
16777215 $E$30
16777215 $F$30
16777215 $G$30
16777215 $H$30
16777215 $A$31
16777215 $B$31
16777215 $C$31
16777215 $D$31
16777215 $E$31
16777215 $F$31
16777215 $G$31
16777215 $H$31
16777215 $A$32
16777215 $B$32
16777215 $C$32
16777215 $D$32
16777215 $E$32
16777215 $F$32
16777215 $G$32
16777215 $H$32
16777215 $A$33
16777215 $B$33
16777215 $C$33
16777215 $D$33
16777215 $E$33
16777215 $F$33
16777215 $G$33
16777215 $H$33
16777215 $A$34
16777215 $B$34
16777215 $C$34
15773696 $D$34
16777215 $E$34
15773696 $F$34
16777215 $G$34
16777215 $H$34
16777215 $A$35
16777215 $B$35
16777215 $C$35
65535 $D$35
16777215 $E$35
5296274 $F$35
16777215 $G$35
16777215 $H$35
16777215 $A$36
16777215 $B$36
16777215 $C$36
65535 $D$36
16777215 $E$36
65535 $F$36
16777215 $G$36
16777215 $H$36
16777215 $A$37
16777215 $B$37
16777215 $C$37
5296274 $D$37
16777215 $E$37
5296274 $F$37
16777215 $G$37
16777215 $H$37
16777215 $A$38
16777215 $B$38
16777215 $C$38
65535 $D$38
16777215 $E$38
5296274 $F$38
16777215 $G$38
16777215 $H$38

DocAElstein

04-07-2021, 08:22 PM

Info from
https://eileenslounge.com/viewtopic.php?p=282295#p282295
https://eileenslounge.com/viewtopic.php?p=282297#p282297

hassona229

Excel 2010 32 bit
16777215 $A$1
16777215 $B$1
16777215 $C$1
16777215 $D$1
16777215 $E$1
16777215 $F$1
16777215 $G$1
16777215 $H$1
16777215 $A$2
16777215 $B$2
16777215 $C$2
16777215 $D$2
16777215 $E$2
16777215 $F$2
16777215 $G$2
16777215 $H$2
16777215 $A$3
16777215 $B$3
16777215 $C$3
16777215 $D$3
16777215 $E$3
16777215 $F$3
16777215 $G$3
16777215 $H$3
16777215 $A$4
16777215 $B$4
16777215 $C$4
16777215 $D$4
**** 15261367 ****** $E$4
16777215 $F$4
16777215 $G$4
16777215 $H$4
16777215 $A$5
16777215 $B$5
16777215 $C$5
16777215 $D$5
16777215 $E$5
16777215 $F$5
16777215 $G$5
16777215 $H$5
16777215 $A$6
16777215 $B$6
16777215 $C$6
16777215 $D$6
16777215 $E$6
16777215 $F$6
16777215 $G$6
16777215 $H$6
16777215 $A$7
16777215 $B$7
16777215 $C$7
16777215 $D$7
16777215 $E$7
16777215 $F$7
16777215 $G$7
16777215 $H$7
16777215 $A$8
16777215 $B$8
16777215 $C$8
16777215 $D$8
16777215 $E$8
16777215 $F$8
16777215 $G$8
16777215 $H$8
16777215 $A$9
16777215 $B$9
16777215 $C$9
16777215 $D$9
16777215 $E$9
16777215 $F$9
16777215 $G$9
16777215 $H$9
16777215 $A$10
16777215 $B$10
16777215 $C$10
16777215 $D$10
16777215 $E$10
16777215 $F$10
16777215 $G$10
16777215 $H$10
16777215 $A$11
16777215 $B$11
16777215 $C$11
16777215 $D$11
16777215 $E$11
16777215 $F$11
16777215 $G$11
16777215 $H$11
16777215 $A$12
16777215 $B$12
16777215 $C$12
16777215 $D$12
16777215 $E$12
16777215 $F$12
16777215 $G$12
16777215 $H$12
16777215 $A$13
16777215 $B$13
16777215 $C$13
16777215 $D$13
16777215 $E$13
16777215 $F$13
16777215 $G$13
16777215 $H$13
16777215 $A$14
16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
**** 15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19
16777215 $F$19
16777215 $G$19
16777215 $H$19
16777215 $A$20

Yasser's friend

Excel 2010 32 bit
16777215 $A$1
16777215 $B$1
16777215 $C$1
16777215 $D$1
16777215 $E$1
16777215 $F$1
16777215 $G$1
16777215 $H$1
16777215 $A$2
16777215 $B$2
16777215 $C$2
16777215 $D$2
16777215 $E$2
16777215 $F$2
16777215 $G$2
16777215 $H$2
16777215 $A$3
16777215 $B$3
16777215 $C$3
16777215 $D$3
16777215 $E$3
16777215 $F$3
16777215 $G$3
16777215 $H$3
16777215 $A$4
16777215 $B$4
16777215 $C$4
16777215 $D$4
**** 15261367 ****** $E$4
16777215 $F$4
16777215 $G$4
16777215 $H$4
16777215 $A$5
16777215 $B$5
16777215 $C$5
16777215 $D$5
16777215 $E$5
16777215 $F$5
16777215 $G$5
16777215 $H$5
16777215 $A$6
16777215 $B$6
16777215 $C$6
16777215 $D$6
16777215 $E$6
16777215 $F$6
16777215 $G$6
16777215 $H$6
16777215 $A$7
16777215 $B$7
16777215 $C$7
16777215 $D$7
16777215 $E$7
16777215 $F$7
16777215 $G$7
16777215 $H$7
16777215 $A$8
16777215 $B$8
16777215 $C$8
16777215 $D$8
16777215 $E$8
16777215 $F$8
16777215 $G$8
16777215 $H$8
16777215 $A$9
16777215 $B$9
16777215 $C$9
16777215 $D$9
16777215 $E$9
16777215 $F$9
16777215 $G$9
16777215 $H$9
16777215 $A$10
16777215 $B$10
16777215 $C$10
16777215 $D$10
16777215 $E$10
16777215 $F$10
16777215 $G$10
16777215 $H$10
16777215 $A$11
16777215 $B$11
16777215 $C$11
16777215 $D$11
16777215 $E$11
16777215 $F$11
16777215 $G$11
16777215 $H$11
16777215 $A$12
16777215 $B$12
16777215 $C$12
16777215 $D$12
16777215 $E$12
16777215 $F$12
16777215 $G$12
16777215 $H$12
16777215 $A$13
16777215 $B$13
16777215 $C$13
16777215 $D$13
16777215 $E$13
16777215 $F$13
16777215 $G$13
16777215 $H$13
16777215 $A$14
16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
**** 15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18

One of my XP 2010 machines

Excel 2010 32 bit
16777215 $A$1
16777215 $B$1
16777215 $C$1
16777215 $D$1
16777215 $E$1
16777215 $F$1
16777215 $G$1
16777215 $H$1
16777215 $A$2
16777215 $B$2
16777215 $C$2
16777215 $D$2
16777215 $E$2
16777215 $F$2
16777215 $G$2
16777215 $H$2
16777215 $A$3
16777215 $B$3
16777215 $C$3
16777215 $D$3
16777215 $E$3
16777215 $F$3
16777215 $G$3
16777215 $H$3
16777215 $A$4
16777215 $B$4
16777215 $C$4
16777215 $D$4
**** 15261367 ****** $E$4
16777215 $F$4
16777215 $G$4
16777215 $H$4
16777215 $A$5
16777215 $B$5
16777215 $C$5
16777215 $D$5
16777215 $E$5
16777215 $F$5
16777215 $G$5
16777215 $H$5
16777215 $A$6
16777215 $B$6
16777215 $C$6
16777215 $D$6
16777215 $E$6
16777215 $F$6
16777215 $G$6
16777215 $H$6
16777215 $A$7
16777215 $B$7
16777215 $C$7
16777215 $D$7
16777215 $E$7
16777215 $F$7
16777215 $G$7
16777215 $H$7
16777215 $A$8
16777215 $B$8
16777215 $C$8
16777215 $D$8
16777215 $E$8
16777215 $F$8
16777215 $G$8
16777215 $H$8
16777215 $A$9
16777215 $B$9
16777215 $C$9
16777215 $D$9
16777215 $E$9
16777215 $F$9
16777215 $G$9
16777215 $H$9
16777215 $A$10
16777215 $B$10
16777215 $C$10
16777215 $D$10
16777215 $E$10
16777215 $F$10
16777215 $G$10
16777215 $H$10
16777215 $A$11
16777215 $B$11
16777215 $C$11
16777215 $D$11
16777215 $E$11
16777215 $F$11
16777215 $G$11
16777215 $H$11
16777215 $A$12
16777215 $B$12
16777215 $C$12
16777215 $D$12
16777215 $E$12
16777215 $F$12
16777215 $G$12
16777215 $H$12
16777215 $A$13
16777215 $B$13
16777215 $C$13
16777215 $D$13
16777215 $E$13
16777215 $F$13
16777215 $G$13
16777215 $H$13
16777215 $A$14
16777215 $B$14
16777215 $C$14
16777215 $D$14
16777215 $E$14
16777215 $F$14
16777215 $G$14
16777215 $H$14
16777215 $A$15
16777215 $B$15
16777215 $C$15
16777215 $D$15
16777215 $E$15
16777215 $F$15
16777215 $G$15
16777215 $H$15
16777215 $A$16
16777215 $B$16
16777215 $C$16
16777215 $D$16
16777215 $E$16
16777215 $F$16
16777215 $G$16
16777215 $H$16
16777215 $A$17
16777215 $B$17
16777215 $C$17
16777215 $D$17
**** 15261367 ****** $E$17
16777215 $F$17
16777215 $G$17
16777215 $H$17
16777215 $A$18
16777215 $B$18
16777215 $C$18
16777215 $D$18
16777215 $E$18
16777215 $F$18
16777215 $G$18
16777215 $H$18
16777215 $A$19
16777215 $B$19
16777215 $C$19
16777215 $D$19
16777215 $E$19

DocAElstein

04-12-2021, 05:03 PM

post for later use

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.php?p=282498#p282498

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.php?p=282498#p282498

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.php?p=282498#p282498

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/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes

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

2655; 661; 663; 665; 667; 6688; 670; 677; 678; 68860-68861; 68864; 68877; 6889; 689; 690; 810; 820
Worksheet: Old

"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"

' 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/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15532#post15532

Old Worksheet:

_____ Workbook: Task.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGH
1NameNumberCodeNoteDateCurrencyMinMax

2John43655; 661; 663; 665; 667; 6688; 670; 677; 678; 68860-68861; 68864; 68877; 6889; 689; 690; 810; 82003-01-2021USD19.8324.79

3Steve43660; 67833; 67890; 67891; 68183; 69903-01-2021USD17.3821.73

4Tom436600; 699003-01-2021USD17.3821.73

5Anthony43644; 664; 680; 681; 688; 69981-69982; 69988-6998903-01-2021USD17.3821.73
Worksheet: Old

New worksheet , Before running macro

Row\ColABCDEFGHI
1NameNumberCodeNoteDateCurrencyMinMax

2
Worksheet: New

New worksheet After running Sub Alex1()

Row\ColABCDEFGH
1NameNumberCodeNoteDateCurrencyMinMax

2John4365503-01-2021USD19.8324.79

3John4366103-01-2021USD19.8324.79

4John4366303-01-2021USD19.8324.79

5John4366503-01-2021USD19.8324.79

6John4366703-01-2021USD19.8324.79

7John43668803-01-2021USD19.8324.79

8John4367003-01-2021USD19.8324.79

9John4367703-01-2021USD19.8324.79

10John4367803-01-2021USD19.8324.79

11John436886003-01-2021USD19.8324.79

12John436886103-01-2021USD19.8324.79

13John436886403-01-2021USD19.8324.79

14John436887703-01-2021USD19.8324.79

15John43688903-01-2021USD19.8324.79

16John4368903-01-2021USD19.8324.79

17John4369003-01-2021USD19.8324.79

18John4381003-01-2021USD19.8324.79

19John4382003-01-2021USD19.8324.79

20Steve4366003-01-2021USD17.3821.73

21Steve436783303-01-2021USD17.3821.73

22Steve436789003-01-2021USD17.3821.73

23Steve436789103-01-2021USD17.3821.73

24Steve436818303-01-2021USD17.3821.73

25Steve4369903-01-2021USD17.3821.73

26Tom43660003-01-2021USD17.3821.73

27Tom43699003-01-2021USD17.3821.73

28Anthony4364403-01-2021USD17.3821.73

29Anthony4366403-01-2021USD17.3821.73

30Anthony4368003-01-2021USD17.3821.73

31Anthony4368103-01-2021USD17.3821.73

32Anthony4368803-01-2021USD17.3821.73

33Anthony436998103-01-2021USD17.3821.73

34Anthony436998203-01-2021USD17.3821.73

35Anthony436998803-01-2021USD17.3821.73

36Anthony436998903-01-2021USD17.3821.73
Worksheet: New

DocAElstein

05-07-2021, 10:38 AM

Some further tests in support of this Thread: https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes
this post: https://excelfox.com/forum/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15539&viewfull=1#post15539

Some transpose tests using this test macro

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
3575
https://i.imgur.com/ZZHD5qf.jpg

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.
3576
http://i.imgur.com/jbwTQdl.jpg
https://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/showthread.php/2747-VBA-Macro-which-create-new-lines-by-codes?p=15552&viewfull=1#post15552

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/showthread.php/2756-How-to-calculate-best-bowling-figure-(cricket)

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )
Row\ColABCDEFGHIJKLM
1Player 1OversMaidenRunsWicketsBwl AveEconWidesNo Ballsballsstrike rate5wBBI

2Match 1111.00n/a00.00

3Match 2111.00n/a00.00

4Match 3120.50n/a00.00

5Match 4120.50n/a00.00

6Match 570323.33n/a00.00

7Match 6111.00n/a00.00

8Match 7111.00n/a00.00

9Match 8111.00n/a00.00

10Match 932310.67n/a00.00

11Match 10111.00n/a00.00

12Match 11111.00n/a00.00

13Match 12111.00n/a00.00

14Match 13111.00n/a00.00

15Match 14111.00n/a00.00

16Match 15111.00n/a00.00

17Match 16111.00n/a00.00

18Match 17111.00n/a00.00

19Match 18111.00n/a00.00

20Match 19111.00n/a00.00

21Match 20111.00n/a00.00

22Player 100120264.620.000000.000

23

24Player 2OversMaidenRunsWicketsBwl AveEconWidesNo Ballsballsstrike rate5w

25Match 1n/an/a0n/a

26Match 2n/an/a0n/a
Worksheet: Sheet3

A basic formula to get a maximum value:

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )
Row\Col
N

8MxD

9
3
Worksheet: Sheet3

_____ Workbook: Stats_Template.xls ( Using Excel 2007 32 bit )
Row\Col
N

8MxD

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/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15614&viewfull=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/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15614&viewfull=1#post15614 ) does not error, but I may have missed something due to my lack of experience with Word VBA.

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.

.....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/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=6175&viewfull=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/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10420&viewfull=1#post10420
https://excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10421&viewfull=1#post10421
https://excelfox.com/forum/showthread.php/1324-Loop-Through-Files-In-A-Folder-Using-VBA?p=10422&viewfull=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
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

Alan

DocAElstein

08-22-2021, 02:32 PM

testing image links

Hallo Seit dem letzten Mal habe ich viele Male versucht... Auch habe ich es in einem anderen Drucker versucht. Außerdem habe ich weitere Patronen gekauft.
Die meisten Patronen funktionieren die meiste Zeit in allen Druckern, abgesehen von Ihren 2 Patronen, die immer noch in keinem Drucker funktionieren...
_.. <stellen Sie sicher..die schwarze Abdeckung entfernt wurde, bevor Sie die Tinte installieren….. Wischen Sie die Chips und den Kontaktpunkt …> . - Ja, ich kenne das alles schon sehr gut und habe es schon oft versucht
_..<.. Bersetzen Sie durch Ihre eigene Patrone, ob Problem verschwindet …> .. - Ja, ich habe viele meiner Patronen ausprobiert und das Problem ist dann immer verschwunden
_...< Fotos der auf Ihrem Drucker angezeigten Fehlermeldung…> rote lichter zeigen immer - http://i.imgur.com/p04geAd.jpg
_..< .. Foto zeigt Ihr Druckermodell ..> ich habe 2 http://i.imgur.com/6pR66Gk.jpg . Eins benutze ich viel, http://i.imgur.com/k8ldcax.jpg , das andere ist eine Reserve und wird nicht viel verwendet , http://i.imgur.com/SsIaPZN.jpg
Ich habe auch mit dem meiner Frau experimentiert , http://i.imgur.com/3D9GVBt.jpg
ALLE SIND DAS GLEICHE MODELL HP Deskjet 1050A - http://i.imgur.com/DigfVU5.jpg
_..<.. Wie viele Tintenpatronen haben Sie ausprobiert .. welche haben nicht funktioniert? ..> - Ich habe 6 meiner Patronen ausprobiert. Die Patronen stammen aus 3 verschiedenen Quellen:-
_ Ich habe neu im lokalen Geschäft gekauft - http://i.imgur.com/2js4bjY.jpg
_ Ich habe neu im Internet - http://i.imgur.com/Ln6DkAG.jpg
_ Ich habe auch zwei von einem kaputten Drucker - http://i.imgur.com/YwqulO8.jpg , http://i.imgur.com/BdRbG1W.jpg , http://i.imgur.com/MnTGALx.jpg

Also habe ich 6 verschiedene Patronen von mir ausprobiert. (Alle sind original HP http://i.imgur.com/x8IYpp4.jpg , http://i.imgur.com/lxjGZqq.jpg , http://i.imgur.com/xhF5tnO.jpg , http://i.imgur.com/9G9HuUt.jpg , http://i.imgur.com/MnTGALx.jpg ). - Alle funktionieren die meiste Zeit in allen meinen Druckern, - http://i.imgur.com/YOFWpT1.jpg , http://i.imgur.com/xJL04SQ.jpg , http://i.imgur.com/sL0VbdT.jpg , http://i.imgur.com/WvrC9D3.jpg

Die Patronen von Ihnen funktionieren immer noch in keinem meiner Drucker - http://i.imgur.com/p04geAd.jpg

Alan

Hallo Seit dem letzten Mal habe ich viele Male versucht... Auch habe ich es in einem anderen Drucker versucht. Außerdem habe ich weitere Patronen gekauft.
Die meisten Patronen funktionieren die meiste Zeit in allen Druckern, abgesehen von Ihren 2 Patronen, die immer noch in keinem Drucker funktionieren...
_..<stellen Sie sicher..die schwarze Abdeckung entfernt wurde, bevor Sie die Tinte installieren….. Wischen Sie die Chips und den Kontaktpunkt …> . - Ja, ich kenne das alles schon sehr gut und habe es schon oft versucht
_..<.. Bersetzen Sie durch Ihre eigene Patrone, ob Problem verschwindet …> .. - Ja, ich habe viele meiner Patronen ausprobiert und das Problem ist dann immer verschwunden
_...< Fotos der auf Ihrem Drucker angezeigten Fehlermeldung…> rote lichter zeigen immer - http://i.imgur.com/p04geAd.jpg
_..< .. Foto zeigt Ihr Druckermodell ..> ich habe 2 http://i.imgur.com/6pR66Gk.jpg . Eins benutze ich viel, http://i.imgur.com/k8ldcax.jpg , das andere ist eine Reserve und wird nicht viel verwendet , http://i.imgur.com/SsIaPZN.jpg
Ich habe auch mit dem meiner Frau experimentiert , http://i.imgur.com/3D9GVBt.jpg
ALLE SIND DAS GLEICHE MODELL HP Deskjet 1050A - http://i.imgur.com/DigfVU5.jpg
_..<.. Wie viele Tintenpatronen haben Sie ausprobiert .. welche haben nicht funktioniert? ..> - Ich habe 6 meiner Patronen ausprobiert. Die Patronen stammen aus 3 verschiedenen Quellen:-
_ Ich habe neu im lokalen Geschäft gekauft - http://i.imgur.com/2js4bjY.jpg
_ Ich habe neu im Internet - http://i.imgur.com/Ln6DkAG.jpg
_ Ich habe auch zwei von einem kaputten Drucker - http://i.imgur.com/YwqulO8.jpg , http://i.imgur.com/BdRbG1W.jpg , http://i.imgur.com/MnTGALx.jpg

Also habe ich 6 verschiedene Patronen von mir ausprobiert. (Alle sind original HP http://i.imgur.com/x8IYpp4.jpg , http://i.imgur.com/lxjGZqq.jpg , http://i.imgur.com/xhF5tnO.jpg , http://i.imgur.com/9G9HuUt.jpg , http://i.imgur.com/MnTGALx.jpg ). - Alle funktionieren die meiste Zeit in allen meinen Druckern, - http://i.imgur.com/YOFWpT1.jpg , http://i.imgur.com/xJL04SQ.jpg , http://i.imgur.com/sL0VbdT.jpg , http://i.imgur.com/WvrC9D3.jpg

Die Patronen von Ihnen funktionieren immer noch in keinem meiner Drucker - http://i.imgur.com/p04geAd.jpg

Alan

Hallo Seit dem letzten Mal habe ich viele Male versucht... Auch habe ich es in einem anderen Drucker versucht. Außerdem habe ich weitere Patronen gekauft.
Die meisten Patronen funktionieren die meiste Zeit in allen Druckern, abgesehen von Ihren 2 Patronen, die immer noch in keinem Drucker funktionieren...
_.. < stellen Sie sicher..die schwarze Abdeckung entfernt wurde, bevor Sie die Tinte installieren….. Wischen Sie die Chips und den Kontaktpunkt …> . - Ja, ich kenne das alles schon sehr gut und habe es schon oft versucht
_..<.. Bersetzen Sie durch Ihre eigene Patrone, ob Problem verschwindet …> .. - Ja, ich habe viele meiner Patronen ausprobiert und das Problem ist dann immer verschwunden
_...< Fotos der auf Ihrem Drucker angezeigten Fehlermeldung…> rote lichter zeigen immer - http://i.imgur.com/p04geAd.jpg
_..< .. Foto zeigt Ihr Druckermodell ..> ich habe 2 http://i.imgur.com/6pR66Gk.jpg . Eins benutze ich viel, http://i.imgur.com/k8ldcax.jpg , das andere ist eine Reserve und wird nicht viel verwendet , http://i.imgur.com/SsIaPZN.jpg
Ich habe auch mit dem meiner Frau experimentiert , http://i.imgur.com/3D9GVBt.jpg
ALLE SIND DAS GLEICHE MODELL HP Deskjet 1050A - http://i.imgur.com/DigfVU5.jpg
_..<.. Wie viele Tintenpatronen haben Sie ausprobiert .. welche haben nicht funktioniert? ..> - Ich habe 6 meiner Patronen ausprobiert. Die Patronen stammen aus 3 verschiedenen Quellen:-
_ Ich habe neu im lokalen Geschäft gekauft - http://i.imgur.com/2js4bjY.jpg
_ Ich habe neu im Internet - http://i.imgur.com/Ln6DkAG.jpg
_ Ich habe auch zwei von einem kaputten Drucker - http://i.imgur.com/YwqulO8.jpg , http://i.imgur.com/BdRbG1W.jpg , http://i.imgur.com/MnTGALx.jpg

Also habe ich 6 verschiedene Patronen von mir ausprobiert. (Alle sind original HP http://i.imgur.com/x8IYpp4.jpg , http://i.imgur.com/lxjGZqq.jpg , http://i.imgur.com/xhF5tnO.jpg , http://i.imgur.com/9G9HuUt.jpg , http://i.imgur.com/MnTGALx.jpg ). - Alle funktionieren die meiste Zeit in allen meinen Druckern, - http://i.imgur.com/YOFWpT1.jpg , http://i.imgur.com/xJL04SQ.jpg , http://i.imgur.com/sL0VbdT.jpg , http://i.imgur.com/WvrC9D3.jpg

Die Patronen von Ihnen funktionieren immer noch in keinem meiner Drucker - http://i.imgur.com/p04geAd.jpg

Alan

Hallo
Seit dem letzten Mal habe ich viele Male versucht... Auch habe ich es in einem anderen Drucker versucht. Außerdem habe ich weitere Patronen gekauft.
Die meisten Patronen funktionieren die meiste Zeit in allen Druckern, abgesehen von Ihren 2 Patronen, die immer noch in keinem Drucker funktionieren...
_.. < stellen Sie sicher..die schwarze Abdeckung entfernt wurde, bevor Sie die Tinte installieren….. Wischen Sie die Chips und den Kontaktpunkt …> . - Ja, ich kenne das alles schon sehr gut und habe es schon oft versucht
_..<.. Bersetzen Sie durch Ihre eigene Patrone, ob Problem verschwindet …> .. - Ja, ich habe viele meiner Patronen ausprobiert und das Problem ist dann immer verschwunden
_...< Fotos der auf Ihrem Drucker angezeigten Fehlermeldung…> - rote lichter zeigen immer - http://i.imgur.com/p04geAd.jpg
_..< .. Foto zeigt Ihr Druckermodell ..> ich habe 2 http://i.imgur.com/6pR66Gk.jpg . Eins benutze ich viel, http://i.imgur.com/k8ldcax.jpg , das andere ist eine Reserve und wird nicht viel verwendet , http://i.imgur.com/SsIaPZN.jpg
Ich habe auch mit dem meiner Frau experimentiert , http://i.imgur.com/3D9GVBt.jpg
ALLE SIND DAS GLEICHE MODELL HP Deskjet 1050A - http://i.imgur.com/DigfVU5.jpg
_..<.. Wie viele Tintenpatronen haben Sie ausprobiert .. welche haben nicht funktioniert? ..> - Ich habe 6 meiner Patronen ausprobiert. Die Patronen stammen aus 3 verschiedenen Quellen:-
_ Ich habe neu im lokalen Geschäft gekauft - http://i.imgur.com/2js4bjY.jpg
_ Ich habe neu im Internet - http://i.imgur.com/Ln6DkAG.jpg
_ Ich habe auch zwei von einem kaputten Drucker - http://i.imgur.com/YwqulO8.jpg , http://i.imgur.com/BdRbG1W.jpg , http://i.imgur.com/MnTGALx.jpg

Also habe ich 6 verschiedene Patronen von mir ausprobiert. (Alle sind original HP http://i.imgur.com/x8IYpp4.jpg , http://i.imgur.com/lxjGZqq.jpg , http://i.imgur.com/xhF5tnO.jpg , http://i.imgur.com/9G9HuUt.jpg , http://i.imgur.com/MnTGALx.jpg ). - Alle funktionieren die meiste Zeit in allen meinen Druckern, - http://i.imgur.com/YOFWpT1.jpg , http://i.imgur.com/xJL04SQ.jpg , http://i.imgur.com/sL0VbdT.jpg , http://i.imgur.com/WvrC9D3.jpg

Die Patronen von Ihnen (http://i.imgur.com/NwM9JBg.jpg , http://i.imgur.com/byeNd0X.jpg ) funktionieren immer noch in keinem meiner Drucker - http://i.imgur.com/p04geAd.jpg

Alan

https://i.postimg.cc/wxsdHN33/CodeTags.jpg

DocAElstein

08-26-2021, 10:30 AM

In support of these forum Threads:
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

Sub GetPicturesFromWordDocument() ' 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
Dim strFile As String, strFileType As String, strPath As String, strOriginalFile As String, strDocumentName As String
Dim lngLoop As Long
Let strFileType = "*.png;*.jpeg;*.jpg;*.bmp" 'Split with semi-colon if you want to specify more file types

Let strOriginalFile = ActiveDocument.FullName
Let strDocumentName = Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) ' 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.
Let strPath = ActiveDocument.Path ' We also store the path to the current active document in strPath

ActiveDocument.SaveAs strPath & "\" & strDocumentName, wdFormatHTML, , , , , True ' 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??

If Dir(strPath & "\MovedToHere", vbDirectory) = "" Then MkDir strPath & "\MovedToHere" ' 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

For lngLoop = LBound(Split(strFileType, ";")) To UBound(Split(strFileType, ";")) ' ======================== 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
Let strFile = Dir(strPath & "\" & strDocumentName & "_files\" & Split(strFileType, ";")(lngLoop))
Do While strFile <> "" ' 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.
Name strPath & "\" & strDocumentName & "_files\" & strFile As strPath & "\MovedToHere\" & "New " & strFile ' 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
Let strFile = Dir ' 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
Loop
Next lngLoop ' ================================================== ==========================================

ActiveDocument.Close 0 ' 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
Documents.Open strOriginalFile ' 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.

Kill strPath & "\" & strDocumentName & ".htm*"
If Not Dir(strPath & "\" & strDocumentName & "_files\*.*") = "" Then Kill strPath & "\" & strDocumentName & "_files\*.*" ' 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.
RmDir strPath & "\" & strDocumentName & "_files" ' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/rmdir-statement
'strFile = vbNullString ' These last few lines are not needed in VBA. These code lines were considered good practice in programming earlier, I think. Possibly they may have sometimes been needed previously. I am not sure.
'strFileType = vbNullString
'strPath = vbNullString
'lngLoop = Empty

End Sub

DocAElstein

10-19-2021, 02:38 PM

Some extra notes in support of this Thread post:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630
Einige zusätzliche Hinweise zur Unterstützung dieses Thread-Beitrags:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630

Anfangs, als Laie, dachte ich, dass eine Fritzbox keine Zugangsdaten braucht. Das war falsche. Aber hier erkläre ich warum ich das gedacht haben:

Diese Screenshots zeigen einen typischen automatisierten Prozess, der beim ersten Anschließen eines neuen FRITZ!Box 7590 Routers startet
https://i.postimg.cc/vTJ9T8b9/FRITZ-Box-7590-First-use.jpg
https://i.postimg.cc/hGcLVGx1/FRITZ-Box-7590-First-use.jpg
https://i.postimg.cc/gjX8GLFm/FRITZ-Box-7590-First-use.jpg
https://i.postimg.cc/fbCxChfn/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/wTRQpZgL/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/rs3G4CCD/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/6QfhPZwP/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/MpkbK5p4/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/SsQGbKxx/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/4NYB3nbK/FRITZ-Box-7590-First-use-Nem-Empholung.jpg
https://i.postimg.cc/3Jz907nt/FRITZ-Box-7590-First-use-Nem-Empholung.jpg

und die letzten leeren Zugangsdatenfelder auch nach Neustarts leer bleiben.
https://i.postimg.cc/66jMwCRJ/After-FRITZ-Box-7590-First-second-use-Nem-Empholung-nor-zugang-date-shown-but-all-works.jpg

Aber der Router funktioniert, um Ihnen Internet zur Verfügung zu stellen, daher gehe ich davon aus, dass die verwendeten Zugangsdaten irgendwo innerhalb der Router an einem Ort gespeichert sind, auf den Sie keinen Zugriff haben.

(Wenn Sie später Zugangsdaten manuell hinzufügen, werden die intern gespeicherten Zugangsdaten mit Ihren Eingaben überschrieben und Ihre Eingaben werden in diesen letzten Feldern später immer angezeigt.)
https://i.postimg.cc/Hn2Xm6mM/FRITZ-Box-7590-Manual-Give-Zugansdaten.jpg
https://i.postimg.cc/prTX9C8z/FRITZ-Box-7590-After-Manual-Give-Zugansdaten-can-see-all-but-Persoenliches-Kennwort.jpg

Anfangs dachte ich fälschlicherweise, dass eine Fritzbox keine Zugangsdaten braucht.

DocAElstein

10-19-2021, 03:15 PM

Some extra notes in support of this Thread post:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630
Einige zusätzliche Hinweise zur Unterstützung dieses Thread-Beitrags:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630

Kopien einiger der fehlenden Frageposts
Copies of some of the missing initial question posts

Speedport W504V - kann nicht kommunizieren. Online, verbunden, aber antwortet nicht auf 192.168.2.1 oder https://speedport.ip in der Adressleiste
( DSL alles in Ordnung, aber nur 4 grün licht beleuchtet und keine funktionieren Telefon oder Internet

Hello
Ich bin zum ersten Mal hier und meine Muttersprache ist nicht Deutsch, also gehen Sie bitte schonend mit mir um, und ich entschuldige mich im Voraus für fehlerhafte Posting-Protokolle :)

Ich habe schon oft einige ähnliche forumsbeitrag durchgelesen, beispielsweise:
https://www.dsl-forum.de/threads/18403-speedport-w504v-nicht-ansprechbar?p=120241#post120241
https://www.dsl-forum.de/threads/18403-speedport-w504v-nicht-ansprechbar?p=120241#post120241
https://www.dsl-forum.de/threads/21258-speedport-w504v-kein-zugriff-mehr-moeglich
https://www.dsl-forum.de/threads/21258-speedport-w504v-kein-zugriff-mehr-moeglich

Sie scheinen um das Problem herumzureden, kamen aber nie zu einer vollständigen Lösung.
Jetzt habe ich das gleiche Problem und suche Hilfe

Das spezifische aktuelle Problem:
Mein Router, ein Speedport W504V, verbindet sich erfolgreich mit jedem meiner Computer.(WLAN oder LAN kable)
Verschiedene Dinge bestätigen mir, dass die Speedport W504V die IP-Adresse 192.168.2.1 hat, wie es sollte.
Verschiedene Dinge und Leute haben bestätigt, dass mit dem DSL-Anschluss alles in Ordnung ist.
Verschiedene Dinge deuten darauf hin, dass ich online bin und eine funktionierende DSL-Verbindung habe.
Ich habe nie bewusst versucht, interne Einstellungen des Routers zu ändern
Aber das Problem:
_ Internet (und Telefon) funktioniert jetzt nicht. (Es hat für viele Jahre zuvor funktioniert)
_ beim IP 192.168.2.1 oder https://speedport.ip in die Adresszeile eingebe, kommt nur "Fehler: Netzwerk-Zeitüberschreitung - Der Server unter speedport.ip braucht zu lange, um eine Antwort zu senden." Egal mit welchem Browser oder Computer, ( und ich habe viele Computern und Browsers ).

Einige allgemeinere Hintergründe/ wie das Problem entstanden ist
Für etwa 10 Jahr habe ich eine Speedport W504V als teil meine Haupt Festnetz DSL Flatrate Internet Haus Anschluss Auftrag mit Deutscher Telekom
Meist war es zuverlässig. Wenn alles gut funktioniert, funktionieren Telefon und Internet und alle 5 grünen Lichter am Speedport W504V Leuchten: Von links nach rechts werden diese grünen Lichter wie folgt angezeigt:
Power *
DSL *
Online *
WLAN *
Telefon *

In der Vergangenheit es trat oft ein ähnliches Problem auf, aber im **Durchschnitt nur einmal in der Woche: Internet und Telefon funktionierten nicht mehr. Fast immer, wenn dies geschah, das letzte Licht, das Telefon licht, leuchtete nicht mehr. Es werden also nur 4 der 5 Lichter angezeigt.
(Ich habe noch nie eine andere Situation erlebt, außer
_ dass alle 5 Lichter aufleuchten, wenn alles funktioniert,
oder
_ nur die ersten 4 Lichter aufleuchten, wenn Telefon und Internet verloren gehen).

( ** aber ich betone im Durchschnitt: Manchmal kann es ein paar Mal in der Woche passieren, manchmal kann es nur einmal im Monat passieren)

Normalerweise wird das Problem behoben, indem man den Stecker aus dem Router (Telekom Speedport W504V) zieht, 30 Sekunden wartet und dann wieder verbindet. Meist klappt es beim erste versuche, konnte aber mal das bis eine Stunde und mehrerer versuche bis alles wieder gut war – Aber eine lange Pause ohne Internet und Telefon war eine Ausnahme

Zunehmend seit etwa die letzte 2 Monaten, war es langer bis die „Stecker raus, warten, Stecker rein Lösung“ funktioniert. Also öfter mal eine Pause im Internet und Telefon. Es trat ein paar Stunden auf, dann war es ein paar Mal für einen Tag weg und das neueste Problem, das ist noch seit fast zwei Woche. Also mit dem Speedport bin ich jetzt in die 4 grün licht keine Internet oder Telefone zustand jetzt dauernde.
Mein erster Hilferuf ging an die Telekom. Es folgten viele Telefon- und E-Mail-Gespräche mit verscheiedener Leute von Telekom. Viele von ihnen haben die Telefonleitung überprüft - alles gut - in ihren Worten: Alle Versuche, die "Synchronisation" zu überprüfen, sagen ihnen, dass die Leitung in Ordnung ist. Verscheiedener Leute von Telekom können auch von ihrem Ende aus , aus der Ferne sehen, wenn ich das "stecker raus, warten, stecker rein" mache.
Aber sie können nicht verstehen, warum ich nicht mit meinem Speedport W 504V kommunizieren kann.
Also gaben sie auf.

Der Speedport W504V ist mein Router - ich habe ihn bei der Telekom gekauft, nicht gemietet. Es ist außerhalb der Garantiezeit und sie wollten es sowieso nicht ersetzen.
Ich miete jetzt einen neuen Router von Telekom. ( FRITZ!Box 7590 ). Es funktioniert .. meistens hab ich Internet an manche meine Computern , aber auch nicht ohne einige neue Probleme - aber das ist ein separates Thema.

Zu meiner eigenen Zufriedenheit würde ich gerne weiterhin sehen, ob ich den Speedport W504V wieder zum Laufen bringen kann, weil, in Zukunft könnte ich viel mehr auf ein funktionierendes Internet angewiesen sein und von zu Hause aus arbeiten, daher möchte ich so viel Kontrolle und Verständnis dafür haben.
Telekom nützt mir in dieser Speedport W 504V Frage / Probleme nichts mehr.

Kann mir hier jemand etwas zum Ausprobieren empfehlen?

Bitte, ich bin ein Laie mit fast keinen Computerkenntnissen. Aber ich bin lernbegierig. Ich habe Computer mit XP, Vista, Windows 7 und Windows 10 für mich verfügbar. Ich bin mit den älteren Betriebssystemen vertrauter, aber ich kann alle Vorschläge mit jedem System ausprobieren, aber ich bräuchte aufgrund meiner begrenzten Computerkenntnisse klare Anweisungen.
Außerdem: Bitte verzeihen Sie mir und denken Sie nicht, dass ich Sie ignoriere, wenn ich lange brauche, bis ich antworte. Ich habe derzeit nur eingeschränkten Zugang zum Internet. Aber ich werde hier auf jeden Fall häufig nachsehen und so schnell wie möglich Antworten geben. Aber das kann dauern

Danke
Alan Elston

( PS Eine Sache, ich bin mir nicht sicher, ob das relevant sein könnte. Telekom sagt mir, dass mein Anschluss ein dynamischer / automatischer ist: Wenn ich die neue Fritzbox anschließe, bekomme ich VDSL aus der festnetz ; Wenn ich den älteren Speedport anschließe, wird es automatisch auf geschaltet gib das langsamere DSL aus der festnetz

PS 2 Hier der Link zu meiner diesbezüglichen Frage im Telekom Hilfeforum:
https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/td-p/5342695
https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/td-p/5342695
** Es ist Gelöst markiert, ist aber nicht gelöst , meine Meinung nach )

Edit PS 3 Eine letzte Sache, etwas Seltsames. Ich verwende manchmal ein kostenpflichtiges VPN. ( hide.me über OpenVPN oder SoftEther ). In der Vergangenheit, als ich die "4 nur Lichter kein Internet- oder Telefon problem" hatte, passierte oft etwas Seltsames. Wenn ich einen Computer über VPN verbunden hatte, dann hatte dieser Computer noch einige Zeit einen funktionierenden Internetzugang. Bei meinem aktuellen Problem hatte ich immer noch Internet auf einem Computer über SoftEther für zwei Tage in dem aktuellen Langzeitproblem!!! - Wenn ich während dieser Zeit das VPN auf diesem Computer trennte, hatte ich ohne VPN kein Internet. Durch das erneute Verbinden dieses Computers über VPN hatte ich wieder ein funktionierendes Internet
( Ich sollte hier auch sagen, dass ich bei meinen verschiedenen Experimenten zur Lösung des Problems manchmal alle Computer getrennt und ausgeschaltet habe. Das hat mir nicht geholfen das Problem zu lösen
)

DocAElstein

10-19-2021, 03:24 PM

Some extra notes in support of this Thread post:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630
Einige zusätzliche Hinweise zur Unterstützung dieses Thread-Beitrags:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630

Kopien einiger der fehlenden Frageposts ( Nicht komplete )
Das sind nur einige meiner groben Notizen

Copies of some of the missing initial question posts ( Not complete )
They are just some of my rough notes

Beispiels: ....... mit dem Speedport W 504V wird es ab Montag nicht mehr funktionieren, da dieser kein VDSL verarbeiten kann. https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5350381/highlight/true#M1390337
....... Die Leitung schaltet sich Montag automatisch rauf und lässt sich nicht mehr stoppen. Der VDSL-Port ist variabel und schaltet sich runter, damit dein Speedport 504V das auch packt https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5352431/highlight/true#M1390697

Vielleicht die Frage anders stellen. Sagen wir, ich habe einen perfekten, voll funktionsfähigen Speedport W504V. (Ich werde wahrscheinlich in ein oder zwei Tagen haben, weil ich ein paar bei ebay vorgestern gekauft habe)
Das hätte vor ein paar Wochen bei meinem bisherigen Telekom DSL 16.000 RAM IP funktioniert

Ich habe jetzt VDSL 50. Ich weiß, dass die Fritzbox funktioniert, (meistens)

Aber wird irgendwo etwas zurückfallen, Rückfall oder sonst was zaubern, damit ein Speedport noch funktioniert.

Einige Leute bei der Telekom haben mir gesagt, dass es so sein wird. Einige waren anderer Meinung. Telekom wissen es also nicht!

Hi Broesel
Danke für die Antwort.

deine Lan-Verbindungen an der Frizbox 7590 (Netzwerkkabel-Verbindungen) funktionieren ja laut deiner Beschreibung.--
Gerade jetzt scheint die Fritz Box 7590 auf den meisten meiner Computer korrekt zu funktionieren und bietet ein stabiles Internet über WLAN oder LAN.
Daran möchte ich jetzt noch nichts machen, bin aber natürlich daran sehr interessiert, eventuell gegen Ende der Woche noch einmal zu experimentieren, also werde ich dann jeden Vorschläge ausprobieren.

... funktioniert aber nur wenn du SSID und WLAN-Schlüssel deines Speedport W 504 V "nie geändert" hast.
Schau mal auf die Rückseite/Unterseite deines Speedport W 504 V....
Ich hatte es neu gekauft, es hat noch nie jemand etwas geändert, und zum Beispiel nutze ich die WLAN-Info auf die Rückseite, wenn ich nach Passwörtern usw. gefragt werde. Das alles hat immer funktionieret mit dem info von die Rückseite

Zu den Einstellungen an der Fritz Box 7590:
Ich verstehe nicht allzu viel über die technischen Details der Einstellungen. Nach einigem Herumspielen am vor letzten Wochenende, als ich es ausgepackt und zum ersten Mal angeschlossen habe, hat es irgendwann beim LAN Verbindung kable zu einer meine Laptops , einen automatischen Einrichtungsvorgang gestartet, den ich laufen gelassen habe, und einfach alle vorgeschlagenen Einstellungen belassen und auf "Weiter" klicken "-Taste, bis es fertig war (Die ganze Geschichte hier: https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5352210/highlight/true#M1390641 )
Am Ende des Prozesses wurden mir diese Informationen präsentiert:
https://i.postimg.cc/HW8m5XYb/Fritzbox-fertig-einrichtung.jpg
https://i.postimg.cc/sDFrJxxq/Fritzbox-fertig-einrichtung.jpg
https://i.postimg.cc/jdzr3TJ5/Fritzbox-fertig-einrichtung.jpg
Gleichzeitig begann das Internet auf allen bisher angeschlossenen Computern voll zu funktionieren

...Du könntest z.B. die SSID und den WLan-Schlüssel deines Speedport W 504 V auf die Fritzbox 7590 übertragen (umschreiben).
Das speichern nicht vergessen......
So mach ich es immer wenn ich mal einen anderen WLan-Router benutze und i.d.R. klappt das auch.
Das merk ich z.B. daran wenn bei uns zu Hause niemand meckert.
gerade benutze und experimentiere nur ich mit Dingen, daher denke ich, dass ich die Dinge vorerst so lassen werde, wie sie sind, aber das könnte eine Idee für später sein, danke für den Vorschlag.

....
Am besten auf Verschlüsselungsstärke WPA/WPA2. Dein Speedport und die Fritzbox können das.
Ich bin mir nicht sicher, wie ich das machen würde. Vielleicht habe ich diese Einstellung schon? - hier wird ein WPA2 angezeigt https://i.postimg.cc/HW8m5XYb/Fritzbox-fertig-einrichtung.jpg

Alan

Hi
Ja, ich vermutete auch, dass die Situation einigermaßen günstig war, mir einen VDSL-Vertrag zu unterjubeln.
Aber nach 10 Jahren habe ich erwartet, dass es an der Zeit sein könnte, ein wenig zu aktualisieren, zumal ich in ein paar Monaten zu Hause möglicherweise mehr beschäftigt und auf ein gutes Internet angewiesen bin.
Vielleicht war das Mieten des Modems/Routers im Nachhinein keine so gute Idee. Ich hatte nicht gedacht, dass ich sie so günstig kaufen kann. Auf der anderen Seite sollte ich bei einem gemieteten Gerät bessere Hilfe erwarten, wenn ich irgendwelche Probleme habe, die mit dem Modem/Router zusammenhängen könnten.

Mein alter Vertrag ( DSL 16.000 ) hat 35 Euro komplett im Monat gekostet. Anscheinend habe ich den Speedport gekauft - ich erinnere mich jetzt nicht mehr. Der neue Vertrag ist auf 35 Euro für 6 Monate festgelegt, danach kostet er 40 Euro pro Monat. Der Vertrag hat eine Mindestlaufzeit von 24 Monaten, was der übliche Deal ist. Die FRITZ!Box 7590 kostet 8 Euro monatlich, 12 Monate Mindestmietdauer.

Vielleicht hätte ich einen besseren Deal machen können, aber wenn sich die Fritzbox beruhigt und ich das verbleibende seltsame Problem lösen kann, das bei einigen meiner Computer festgestellt wurde, dann werde ich vielleicht die Dinge so lassen, wie sie sind.

Ich denke, ein Speedport W723V ist für VDSL in Ordnung, und sie scheinen genauso billig zu sein wie ein Speedport W504V bei ebay. Vielleicht werde ich mir also ein paar davon kaufen, nur um es in den nächsten Tagen zum Spaß auszuprobieren.

....dein W504 hat definitiv KEINEN variablen Schalter und wird an einem VDSL-Anschluß nicht funktionieren. ....

Ich habe mich wohl nicht ganz klar erklärt. Was ich meinte war, dass einige Leute bei der Telekom vorgeschlagen haben, dass sich die automatische Umschaltung in einer nahegelegenen Box befindet, wahrscheinlich was ich nahe meinem neresten Nachbar gesehen habe: Vor einigen Jahren tauchte neben der alten kleineren eine viel größere Telekom-Box auf. Bei Recherchen im Internet sieht es so aus:
https://de.wikipedia.org/wiki/Very_High_Speed_Digital_Subscriber_Line
https://i.postimg.cc/qhWstCrv/290px-Junction-boxes-Deutsche-Telekom.jpg (https://postimg.cc/qhWstCrv)
Was ich dachte, verstanden zu haben, war, dass sich der Switch in dieser Box befindet und es irgendwie bermerkt , welchen Router ich habe und das gelieferte Signal entsprechend auf DSL oder VDSL ( https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5352431/highlight/true#M1390697 …… Der VDSL-Port ist variabel und schaltet sich runter, damit dein Speedport 504V das auch packt. Also einfach laufen lassen und alles wird gut ….. )
Aber vielleicht habe ich das nicht richtig verstanden.
Jedenfalls haben einige andere bei der Telekom gesagt, dass es keine Chance gibt, dass der Speedport W504V jetzt für mich funktioniert.

Die Informationen, die ich habe, sind also unsicher.

Meine Vermutung eines ungebildeten Laien, basierend auf meinen jüngsten Experimenten, ist, dass ich seit der "Umstellung" vor einer Woche keinen Speedport W504V niemals verwenden könnten , auch wenn er einwandfrei funktionierte so wie er soll.. Ich begründe diese Schlussfolgerung auf folgendem: Seit dem "Schalter" vor einer Woche verhält es sich meind speedport W504V anders:
Wie zuvor leuchten das erste grüne Licht ( Power ) und das vierte grüne Licht ( WLAN ) dauerhaft. Aber jetzt das grüne DSL-Licht blinkt ständig und das grüne OnLine-Licht geht nie an. ( Vorher hatte ich die Situation wie in meinem beschrieben hier (https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden?p=169535&viewfull=1#post169535) – entweder 4 oder 5 grün licht dauende an.
So wie ich es verstehe, bzw. vermute, deutet ein endlos blinkendes DSL-Licht darauf hin, dass es versucht, Kontakt aufzunehmen, aber nie dort ankommt, oder einige Worte in diesem Sinne.

Hello Hardwaremensch.
Ich wollte dich nicht wieder mit einer langen Geschichte langweilen, aber wie du fragst...

…WARUM willst du ihn widerrufen?
Ich bin mir noch nicht sicher, ob ich das machen will, aber wenn ja, muss ich es in den nächsten Tagen tun

Welchen Vertrag hast du denn,
Ich verstehe nicht allzu viel von , aber Du kannst von hier aus sehen,
https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5346069/highlight/true#M1389675
dass Deutscher Telekom mir sagen, dass ich das früher hatte
DSL 16.000 RAM IP ( mit das evtl. jetzt defekt Speedport W504V Typ A )
Und jetzt anscheinend das habe
VDSL 50 und einer FRITZ!Box 7590

Aus einigen anderen Vertrag Papierkram sehe ich, dass ich sie hatte „Magenta Zuhaus S“
Download: Max. 16 MBit/s, Normal 9,5 MBit/s, Min. 6,304 MBit/s
Upload: Max. 2,4 MBit/s, Normal 1,5 MBit/s, Min. 0,704 MBit/s

Und jetzt das neue Vertrag, was ich evtl. widerrufen ist „Magenta Zuhaus M“ VDSL 50
Download: Max. 50 MBit/s, Normal 47 MBit/s, Min. 27,9 MBit/s
Upload: Max. 10 MBit/s, Normal 9,4 MBit/s, Min. 2,7 MBit/s

DocAElstein

10-19-2021, 03:25 PM

Some extra notes in support of this Thread post:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630
Einige zusätzliche Hinweise zur Unterstützung dieses Thread-Beitrags:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630

Kopien einiger der fehlenden Frageposts ( Nicht komplete )
Das sind nur einige meiner groben Notizen

Copies of some of the missing initial question posts ( Not complete )
They are just some of my rough notes

Und WARUM willst du ihn widerrufen?
Wenn ich das tue, hat das mehrere Gründe:
_ Im Nachhinein denke ich, dass etwas mehr Zeit hätte investieren müssen, um zu sehen, ob das anfängliche Problem mit dem Speedport aus den in meinem letzten beitrag (https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden?p=169547&viewfull=1#post169547) genannten Gründen behoben werden könnte

_ Ich habe keine Leistungs- / Geschwindigkeitsverbesserung bemerkt (aber ich gestehe, ich verstehe nicht genug, um gründlich zu testen, und ich kann die Systeme nicht vergleichen, da ich jetzt nur das eine System habe.)

_ Ich war nicht allzu beeindruckt von der Unterstützung, die ich von der Telekom hatte. Es wurde variiert: widersprüchliche Informationen, falsche Informationen oder oft keine Informationen, das heißt manchmal auch keine Antworten. Die verschiedenen Hotlines haben sich als fast so nutzlos erwiesen wie die ausländischen Callcenter, die manche Unternehmen nutzen. Das ist mir derzeit weniger wichtig, aber in ein paar Monaten bin ich vielleicht viel stärker auf einen zuverlässigen Internet zu Hause angewiesen. Der neue Vertrag hat eine Laufzeit von 24 Monaten, den vorherigen könnte ich in ca. einem Drittel dieser Zeit kündigen, wenn ich entscheide, dass die Telekom kein verlässlicher Partner für mich ist.

_ Wenn wir vorerst davon ausgehen, dass mein aktuelles Problem auf ein Problem mit meinem Speedport zurückzuführen ist, ist das neue System viel weniger zuverlässig: Früher hatte ich in den letzten 10 Jahren nur selten Internetverluste. Bisher schlägt das neue System etwa 30 % der Zeit im Internet aus. Das Problem tritt zeitweilig auf und kommt von selbst wieder, aber es nützt nicht viel, wenn ich ein kontinuierliches Internet möchte oder später brauche

_ Auf einigen meiner Computer habe ich ein neues Problem, sie akzeptieren den Netzwerkschlüssel nicht.
( https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5352210/highlight/true#M1390641
)
https://i.postimg.cc/0KkF1YRL/XP-Netzwerkschluessel-error.jpg (https://postimg.cc/0KkF1YRL)
Ich bin mir ziemlich sicher, dass dieses neue Problem auf das neue System zurückzuführen ist, da ich es noch nie zuvor gesehen habe, weder zu Hause noch als diese Laptops häufig von zu Hause aus auf vielen verschiedenen Systemen verwendet wurden.

Aber ich werde drüber schlafen und morgen mit klarem Kopf nachdenken

Ich gehe davon aus, dass die Telekom mir sagen würde, dass es entweder schwierig oder unmöglich ist, die Dinge wieder so zu machen, wie sie waren. Ob das stimmt, ist eine andere Frage.

Alan

https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5352431/highlight/true#M1390697

Als ich gestern Abend vor dem Schlafengehen die ausführlichen Anweisungen meines Speedports gelesen habe, sind einige Dinge aufgefallen, die ich möglicherweise übersehen habe.
Mir ist auch gestern aufgefallen, dass man bei ebay einen Speedport W504V sehr günstig ergattern kann: Habe mir heute Morgen gleich einen gekauft, neu, originalverpackt, komplett für 1 Euro. Eines der Kabel oder das Netzteil allein ist das Geld wert, - auch wenn mir der Speedport nicht hilft, habe ich immer noch ein Schnäppchen. ( Netzteil habe ich noch zu prüfen, wie Du vorgeschlagen hast - also bekomm ich bald einen neuen zum Vergleichen)

Man ist immer schlauer danach – ich hätte besser etwas warten hatten vor ich Telekom kontaktiert, evtl. eine neue Speedport erste aus probiert nach eine mehr gründlich Internet recherchieren und gründliches erneutes Lesen der originalen sehr detaillierten Speedport geliefert Anweisungen.
Für das Extra Geld , das ich pro Monat für meinen neuen Vertrag zahle, hätte ich mehrere neue Speedports kaufen können.

Ich persönlich bevorzuge immer mindestens zwei Lösungen gegenüber allem, was mit Computern und Internet zu tun hat. ( Die neue Fritzbox funktioniert noch nicht einwandfrei. )
Die bessere Lösung für mich könnte sein, zwei Speedports zum Laufen zu bringen, dann kann ich beim nächsten Problem leichter erkennen, was / wo das Problem ist. Ich bin mir immer noch nicht 100% sicher, dass mein Problem nur der Router ist/war, obwohl es bei weitem am wahrscheinlichsten ist. Es könnte aber auch eine seltsame Interaktion mit meinem VPN sein, die etwas im Speedport durcheinander gebracht hat. - Ein paar Mal, als Internet und Telefon zuvor einige Stunden abwesend waren, hatte ich den Verdacht, dass es nach dem Ausschalten eines Computers, der damals über VPN verbunden war, wieder aufkam war. Aber ich konnte mir damals nicht sicher sein.

Mal schauen was meine Wochenende experimentieren bringt. Ich habe noch ein paar Tage Zeit, um vom 14-tägigen Vertrag Widerrufs Recht Gebrauch zu machen, denk ich. - damit noch nicht alles verloren ist

Alan

Just testing ….
Nur testen ….

Danke für die Antwort und Meinung Hardwaremensch, vielleicht haben sie Recht. Im Dschungel dessen, was ich geschrieben habe, habe ich schon erwähnt, dass ich bereits einen neuen Router bei der Telekom miete, aber ich denke, ich würde gerne noch eine Weile versuchen, den Speedport als Hintergrundprojekt zum Laufen zu bringen, bevor ich aufgebe, aus den Gründen, die ich schon erwähnt habe.

Ich habe gestern die original Speedport und Auftrag papierkram von 2011 gefunden in meine Dachboden. Dort gibt es viele Informationen, einschließlich verschiedener Informationen zur ursprüngliche Einstellungen und Einrichtung usw. In den nächsten Tagen werde ich das durchlesen und meine allgemeinen internen Recherchen als Hintergrundprojekt fortsetzen.

In den Original papierkram wird erwähnt, dass die Ersteinrichtung zwischen einer bestimmten Zeit an einem bestimmten Tag erfolgen musste, die in diesem Originalstapel von papierkram angegeben hatten. Ich bin mir der Bedeutung dessen nicht sicher. Eventuell könnte ich nochmal versuchen, Hilfe von der Telekom zu bekommen. Telekom scheinen meinen letzten fragen zu ignorieren. Verständlich denke ich. Ein Autoverkäufer ist nicht so daran interessiert, bei der Reparatur Ihres alten Autos zu helfen, besonders nachdem er Ihnen ein neues verkauft ( vermietet in meine fall ) hat!

Ich habe zu Letzt gesehen, dass der Router ein kleines Loch hat, in das ich einen Stift stecken kann, möglicherweise um eine Art Werkseinstellungen wiederherstellen durchzuführen.
Das klingt nach einer drastischen Maßnahme. Ich werde das wahrscheinlich versuchen als letztes, aber ich werde warten, bis ich versucht habe, ein paar weitere Ideen zu bekommen oder mich ein bisschen besser informiert zu haben.

Alan

Danke, Hardwaremensch, dass Du versucht hast, mir (wieder) etwas vernunft einreden, :)
Ich werde sicherlich bedenken, was Du sagst, aber es ist nicht ganz richtig zu sagen, dass ich versuchst auf Biegen und Brechen einen alten Router zum Laufen zu bringen. Ich war nie besonders daran interessiert, es zu reparieren, und ich war seit letztem Samstag nicht mehr in der Nähe eines Routers.
Ich hatte diese Woche nicht viel Zeit für Computer oder Internet. Alles, was ich zu meinem Problem getan habe, war, ein paar Beiträge zu schreiben, ein wenig zu lesen und ich habe ein paar Speedport W504Vs und W723Vs gekauft.
Ich habe sie nur gekauft, weil sie so unglaublich günstig waren,- die Netzteile und das LAN-Kabel sind mehr wert, als ich dafür bezahlt habe. (Es sind viele Kabel und Anschlüsse in dem, was ich gekauft habe, enthalten. Ich bin mitten in einer langfristigen großen Hausrenovierung, die einen großen Computerraum beinhalten soll. Selbst wenn ich alle Router wegwerfe, kann ich das machen gute Verwendung der anderen Kleinigkeiten.)

Ich habe bereits erklärt, dass es für meine zukünftige Arbeit nützlich sein könnte, die Internetsysteme zu verstehen, die ich habe, die ich hatte und die ich haben könnte.

Letzten Samstag habe ich die Fritzbox angeschlossen gelassen. Die paar Male, die ich auf dem Computer war, hat das Internet funktioniert, also sieht es so aus, als ob die Fritzbox ständig funktioniert. Das Surfen im Internet scheint etwas langsam zu laufen, verglichen mit dem, was ich vorher immer vor meinen letzten Problemen hatte. Aber vielleicht ist das nur Zufall und liegt an etwas anderem als der Fritzbox.

Ich werde auf jeden Fall am Wochenende experimentieren, wenn ich Zeit habe, und mich melden, wenn ich neue Erkenntnisse habe.
Zum Beispiel habe ich jetzt eine neue und zwei vorher normal funktionierende 504Vs. Wenn ich also keine davon bekomme, um mir Internet zu verschaffen, dann weiß ich mit einiger Sicherheit, dass die Antwort auf meine letzte Frage Nein ist. Selbst dann bekomme ich vielleicht noch mehr Einblick in warum / ob das Problem im Titel meines Threads - "Speedport W504V - kann nicht kommunizieren"

Ich erwarte nicht, dass die W723Vs in irgendeiner Hinsicht so gut sind wie die Fritzbox ist. Aber wieder einmal waren sie lächerlich billig, und ich denke, sie sollten in einem VDSL 50-System funktionieren, daher könnte es interessant sein zu sehen, wie sie funktionieren, nur zum Vergleich und meine Experimente. Wenn ich zum Beispiel Internet mit ihnen bekomme, haben sie möglicherweise das gleiche Problem wie die Problem Fritzbox mit einigen meiner Computer oder auch nicht. Das könnte mir helfen, herauszufinden, wo das Problem liegt.

Alan

DocAElstein

10-19-2021, 03:31 PM

Some extra notes in support of this Thread post:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630
Einige zusätzliche Hinweise zur Unterstützung dieses Thread-Beitrags:
https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden/page2?p=169630&viewfull=1#post169630

Kopien einiger der fehlenden Frageposts, bzw fehlenden Thread .. ( https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden )

Copy of the final complete answer
Kopie der endgültigen vollständigen Antwort

Hi
Ich habe jetzt Antworten auf alle Fragen aus diesem Thread.. ( https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden )

____(i) Die Antwort auf ... antwortet nicht auf 192.168.2.1 oder https://speedport.ip in der Adressleiste … die Hauptfrage des Thread-Titels (https://www.dsl-forum.de/threads/25111-speedport-w504v-nicht-kommunizieren-online-verbunden)war, dass die Software, die für den Einstieg in die Einstellung über einen Browser verantwortlich war, seit lange, einschließlich der Zeit, als der Speedport W504V noch recht aktuell war, nicht funktionierte. Die meisten alten /sehr alten Browser funktionieren. Ich habe dies vermisst, da mir am Telefon von Leuten, die mir halfen, geraten wurde, einen neueren Computer und Browser zu verwenden. Dies ist für die meisten Dinge der beste Rat, aber nicht in diesem speziellen Fall.
Die ganze Geschichte hier:
https://telekomhilft.telekom.de/t5/Geraete-Zubehoer/Speedport-W504V-funktioniert-nicht-mehr-im-Festnetz-keines-davon/td-p/5370149

Ein paar andere Dinge nebenbei, auch die für andere besprochene Dinge relevant sind
__ (ii) Mein neuer Ersatz-Router (FRITZ!Box 7290) funktioniert auf einigen älteren Computern nicht: Antwort: Reduzieren Sie das Router-WLAN-Passwort auf 16 Stellen und ändern Sie das Router-WLAN-Sicherheitsding von WPA2 (CCMP) auf WPA + WPA2, um dieses Problem zu beheben
Die ganze Geschichte hier:
https://eileenslounge.com/viewtopic.php?f=21&t=37237

__(iii) Deutsche Telekom Zugangsdaten und t-online.de E-Mail-Anomalien
Ich habe anfangs aus einem seltsamen Grund viel Zeit verschwendet:
Viele Hilfestellungen der Telekom sind automatisiert. Keine Überraschung da.
Was viele nicht wissen, auch die meisten Telekom-Mitarbeiter, mit denen ich gesprochen habe, ist, dass viele Dinge entweder nicht oder viel schlimmer, sehr irreführend und sprunghaft funktionieren, wenn Sie nicht bei einem bestimmten t-online.de Freemail-Konto eingeloggt sind . Viele Leute wie ich wussten nie, dass ich so einen Account habe. So einen Account wird von der Telekom für Sie gemacht haben. (Dies wurde Ihnen möglicherweise in einer frühen Mitteilung, als Sie zum ersten Mal Telekom-Kunde wurden, im Kleingedruckten mitgeteilt)
Die ganze Geschichte hier:
https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5363073/highlight/true#M1392788

__(iv) Zugangsdaten?? Was ist das? So etwas habe ich noch nie gesehen, Kumpel
Dies hängt teilweise mit __(iii) zusammen.
Es gibt eine aktuelle, teil junge, Generation, die denkt, man steckt Dinge ein und sie werden sich selbst initialisieren usw. Dazu gehören mindestens die Hälfte der Telekom-Leute, mit denen ich gesprochen habe.- Wenn etwas nicht sofort funktioniert, werfen Sie es weg, es muss veraltet sein.
( Ich meine nicht besonders alte Geräte - ich stimme zu, dass mein alter Speedport wahrscheinlich weggeworfen / aktualisiert werden muss. Der Punkt, den ich hier ansprechen möchte, ist ein anderer.)
Beim ersten Versuch, meine neue FRITZ!Box 7290 zu benutzen, hat irgendwann eine automatische Initialisierung stattgefunden, und in meiner Unwissenheit habe ich einfach die Standardeinstellungen "empfohlen" akzeptiert und auf Weiter geklickt.
Wenn man dann in die Internet Zugangsdaten schaut.. sieht man keine. Nichts ist da. Alle Eingabefelder sind leer - Zugangsdaten?? Was ist das? So etwas habe ich noch nie gesehen, Kumpel. Ich habe nie gewusst, was Zugangsdaten sind, und die Hälfte der Leute bei der Telekom weiß es immer noch nicht. Der Schuld liegt an der Standardoption, die vermutlich alle diese Daten rein schreibt, und die neueren FRITZ!Box-Router verbergen es dann vor dir.

Nur um klar zu sein, was ich hier sagen will: Als ich das erste Mal die Fritzbox angeschlossen habe (https://telekomhilft.telekom.de/t5/Telefonie-Internet/Ich-kann-keinen-Ausfall-unseres-Telefon-und-Internet-Festnetzes/m-p/5352210/highlight/true#M1390641) , hat ein automatischer Prozess gestartet und ich hatte ein funktionierendes Internet danach. Ich habe nichts außer Weiter geklickt.
Wenn ich dann in "--Internet -- Zugangsdaten --- "- nachgeschaut habe, dann sehe ich auch nach vielen Neustarts keine Einträge ( https://i.postimg.cc/Y0DysTJf/FRITZ-Box-7590-After-first-automatic-working-internet-no-zugansdaten-shown.jpg ).
Mein Laie vermute ist , dass die Fritzbox-Software Dir anzeigt, was Du manuell eingegeben hast. Wenn Du selbst nie etwas eingegeben haben, wird dort nie etwas angezeigt, auch wenn die fritzbox deine Zugangsdaten gespeichert hat.
Dies kann einem Laien helfen, die Informationen zu verbergen, worum es bei den Zugangsdaten geht: Anfangs dachte ich fälschlicherweise, dass eine Fritzbox keine Zugangsdaten braucht.
(Siehe auch hier für detailliertere Screenshots https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15698&viewfull=1#post15698 )

__(v) Mein größeres Hauptproblem des versagenden Internets.
Ich hatte das Gefühl, dass mein Problem nicht unbedingt mein Router war, und dass möglicherweise die geringeren Probleme, die ich seit dem neuen Vertrag und dem neuen Router hatte, einfach darin bestand, dass alles, was falsch war, einen geringeren Einfluss hat auf die neueres, leistungsfähigeres System. Wenn Du zum Beispiel Mist Benzin von deine örtlichen Tankstelle bekommen, damit deine älteres Auto nicht mehr anspringt, also kaufst Du ein neues Auto und es springt an. Also die Tankstelle sagt dir jetzt ist alles gut - dein altes Auto war das Problem.
Also habe ich den neuen Vertrag gekündigt und konnte aufgrund der Erkenntnisse aus _(iii) einen Techniker der Telekom zu mir nach Hause kommen lassen, um meine Anlage zu überprüfen. ( Dieses Hilfesystem läuft parallel zu anderen Hilfesystemen der Telekom, die meisten Leute in der Telekom wissen es nicht, und es läuft aus einem alten Vertrag mit einer privaten Firma - Eine private Telekommunikationsfirma wurde geschickt).
Der Techniker dachte, es sei mein alter Router, bis ich ihm erklärte ____(i)
Dann suchte er mit verschiedenen Testinstrumenten weiter.
Eine fehlerhafte Verbindung in einer Anschlussdose irgendwo wurde erkannt, ersetzt und mein Internet funktionierte wieder wie in den letzten 10 Jahren meist zuverlässig.

Nur als Interesse zum Schluss…
_ (vi) Ich habe die Gelegenheit genutzt, um ein paar Geschwindigkeiten (mit dem www.breitbandmessung.de-Zeug) zu überprüfen, sowohl in der VDSL 50 Vertragszeit als auch in DSL 16.000 RAM IP Vertragszeit.
Ich habe fast** nie einen Leistungsunterschied mit verschiedenen Routern bemerkt
In der VDSL 50 Vertragszeit hatte ich einen Download durchschnittlich 51 Mbit/s, Upload durchschnittlich 11 Mbit/s
In der Vertragslaufzeit von VDSL 50 kann es bei der Nutzung von Kabel-LAN statt WLAN zum Download um einige Mbit/s-Verbesserungen gekommen sein.
In der DSL 16.000 RAM IP Vertragszeit mag es bei meinem ältesten Router im Vergleich zu den anderen einen sehr geringen Leistungsabfall** gegeben haben, aber wenn überhaupt, dann nur ca. .5 Mbit/s im Upload.
In der DSL 16.000 RAM IP Vertragszeit hatte ich einen Download durchschnittlich 12 Mbit/s, Upload durchschnittlich 2 Mbit/s

Die Geschichte hat also ein Happy End. Ich ärgere mich ein wenig, dass ich so viel selbst machen musste, aber das ist meine Entscheidung, ich hätte es leicht haben können, das System durch das neuere ersetzen und das Gleiche in ein oder zwei Jahren tun, wenn/ falls die fehlerhaft Verbindung probleme wäre schlechter.
Aber ich habe ein bisschen gelernt.
Aufgrund meines angewachsenen Wissens wurde mir plötzlich klar, was mein Schwiegervater mir vor einigen Jahren gegeben hatte: Auf dem Dachboden fand ich die alte FRITZ!Box 3270, die er mir gegeben hatte. Ich konnte es manuell einrichten, und es funktioniert, um mich ins Internet zu bringen.
Ich bin also mit vielen Routern und dem Wissen, was man damit macht, gut eingedeckt.
(Ich werde in ein paar Wochen vielleicht wieder auf das bessere VDSL-System updaten, sobald ich überzeugt bin, dass mein derzeitiger Anschluss in Ordnung ist)

Gruß aus Hof
Alan

DocAElstein

10-20-2021, 12:12 AM

Macro coding for this Thread:
https://excelfox.com/forum/showthread.php/2766-Autofill-Text-if-Criteria-are-met?p=15705&viewfull=1#post15705

Option Explicit
Sub AutoNameFill() ' https://excelfox.com/forum/showthread.php/2766-Autofill-Text-if-Criteria-are-met
Rem 1 Worksheet info
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Rem original data in first two columns
Dim arrDta() As Variant: Let arrDta() = Ws1.Range("A4:B" & Lr & "").Value2 ' Data range into an array
Rem modifying the data in the array
Dim Rw As Long ' The data line at any time
Dim celVl As String, Nme As String ' the cell value in column 1 at any row , a name
Do While Rw < Lr - 4 ' ----- Main outer loop for all data rows
Do While InStr(1, celVl, "total", vbBinaryCompare) = 0 And celVl <> "Total" ' This keeps us going until we hit a total
Let Rw = Rw + 1: Let celVl = arrDta(Rw, 1) ' next line : cell value in that line
If celVl <> "" Then Let Nme = celVl ' this will store our current name if we have one
If arrDta(Rw, 2) <> "" And InStr(1, arrDta(Rw, 2), "total", vbBinaryCompare) = 0 Then Let arrDta(Rw, 1) = Nme ' we put the name in if there is data in column 2 and not a total this will also get the name total entry but never mind
Loop ' While InStr(1, celVal, "total", vbBinaryCompare) <> 0 ' This keeps us going until we hit a total
' At this point we have reached a total and so will be moving onto the next name section
Let celVl = "" ' this clears the last name total entry
Loop ' While Rw < (Lr-4) ----- Main outer loop for all data rows

Rem Repasting out the modified data
Ws1.Range("A4:B" & Lr & "").Value2 = arrDta()
End Sub

DocAElstein

10-24-2021, 11:31 AM

Copy from here https://www.excelforum.com/excel-programming-vba-macros/343845-docking-project-explorer-vertically.html#post4545938

For help in this post
https://eileenslounge.com/viewtopic.php?p=289070#p289070

Yep Rob Bovey’s sledgehammer is the Doggy’s Nut‘s. Once again saved a lot of frustration. Just now my Immediate Window got “swallowed” and “eaten” as I moved over it whilst moving the position of my VB Editor Window. All I could do was open or close it after that. The problem was that on opening it, it took up all the entire space in the VB Editor but refused to let me reduce its size or move it in any of the ways that it usually is possible to do. ( So maybe the Immediate Window had sort of swallowed the VB Editor ?? ). In any case something had its knickers in a twist, and all the other ways to get the problem sorted had no effect !!

Following the instructions from Rob Bovey sorted it Out
Absolutely spiffing, Jolly Billy Ho! IMO

Alan

P.s. The thread is a bit Old so the exact steps may be a bit different..
Here is one ( almost) current example...
( Using Windows Vista )

_ 1) Close Excel ***
_ 2) Hit the Microsoft symbol bottom left
_ 3) Type in RegEdit in the small search Window
_ 4) Double click on the RegEdit which should now be offered in the larger window just above the Search Window
( _ 5)( At this point I got an “Administrator Rights” type window pop Up – So you might not get past here depending on your “rights” – I got past by just clicking OK in this pop Up ) )
_ 6) A big registry Window pops up – I navigate through HKEY_CURRENT_USER\Software\Microsoft\VBA\6.0\Commo n
_ 7) Now on the right side of the Registry, I see a Dock . I double click on Dock
_ 8) I have now an Edit Window. It has a large “Value:” Box full with Numbers and letters in it.
_ 9) I Highlight all those Numbers and delete them, ( All but 0000 should then vanish ) , then Hit OK
_ 10) – “Jolly Ruddy Spiffing Billy Merry Ho Wonks Bingo !!” . – On opening Excel I find if I hit Ctrl+G from the VB Editor ( Alt+11 ), my immediate Window appears at the bottom of the VB Editor, but I can drag it in and out of the VB Editor anywhere where I Jolly well like! :)

(*** Do not forget that Excel must be closed or it will not work )

RegEditDockingWonks.JPG http://i.imgur.com/V0qttoA.jpg https://i.postimg.cc/X7qkfYdG/Reg-Edit-Docking-Wonks.jpg
494178
3652
https://i.postimg.cc/X7qkfYdG/Reg-Edit-Docking-Wonks.jpg (https://postimg.cc/MvkBxxsq)

P.P.s. May be this Thread could do with being in the Tips and Tutorials Sub Forum?

DocAElstein

11-05-2021, 01:13 PM

In support of this post:
https://www.eileenslounge.com/viewtopic.php?p=289526#p289526

http://www.excelforum.com/excel-programming-vba-macros/1126564-choose-a-folder-and-loop-a-sub.html#post4315748
http://www.excelforum.com/excel-programming-vba-macros/1126751-get-value-function-loop-through-all-files-in-folder-and-its-subfolders.html#post4316662
http://www.mrexcel.com/forum/excel-questions/918955-macro-code-opening-excel-file.html
http://www.excelforum.com/excel-programming-vba-macros/1126860-is-it-possible-to-sum-entire-column-with-out-opening-excel.html
https://eileenslounge.com/viewtopic.php?f=30&t=28616&p=222840#p222840
https://eileenslounge.com/viewtopic.php?f=30&t=28616&p=226939#p226939
https://eileenslounge.com/viewtopic.php?f=30&t=31150&p=241142#p241142
https://eileenslounge.com/viewtopic.php?f=30&t=31784&p=246079#p246079
https://eileenslounge.com/viewtopic.php?f=30&t=31883&p=247028#p247028
https://eileenslounge.com/viewtopic.php?f=30&t=31150&p=241204#p241204
Range referencing with and without $s https://eileenslounge.com/viewtopic.php?p=241197#p241197
https://eileenslounge.com/viewtopic.php?p=271415#p271415

DocAElstein

11-05-2021, 01:13 PM

In support of this post:
https://www.eileenslounge.com/viewtopic.php?p=289526#p289526

http://www.excelforum.com/excel-programming-vba-macros/1126564-choose-a-folder-and-loop-a-sub.html#post4315748
http://www.excelforum.com/excel-programming-vba-macros/1126751-get-value-function-loop-through-all-files-in-folder-and-its-subfolders.html#post4316662
http://www.mrexcel.com/forum/excel-questions/918955-macro-code-opening-excel-file.html
http://www.excelforum.com/excel-programming-vba-macros/1126860-is-it-possible-to-sum-entire-column-with-out-opening-excel.html
https://eileenslounge.com/viewtopic.php?f=30&t=28616&p=222840#p222840
https://eileenslounge.com/viewtopic.php?f=30&t=28616&p=226939#p226939
https://eileenslounge.com/viewtopic.php?f=30&t=31150&p=241142#p241142
https://eileenslounge.com/viewtopic.php?f=30&t=31784&p=246079#p246079
https://eileenslounge.com/viewtopic.php?f=30&t=31883&p=247028#p247028
https://eileenslounge.com/viewtopic.php?f=30&t=31150&p=241204#p241204
Range referencing with and without $s https://eileenslounge.com/viewtopic.php?p=241197#p241197
https://eileenslounge.com/viewtopic.php?p=271415#p271415

DocAElstein

11-09-2021, 01:06 PM

In support of this post
https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12783
The ps1 file, and also below the $WindowsSearch.Add_Click(
Share ‘ChrisSearchTweaks18-19July.ps1 https://app.box.com/s/cbs7go8i2tdxw4wguthgxcviecaxjn6b
iex ((New-Object System.Net.WebClient).DownloadString(' https://raw.githubusercontent.com/ChrisTitusTech/win10script/71609526b132f5cd7e3b9167779af60051a80912/win10debloat.ps1'))

$windowssearch.Add_Click({
Write-Host "Disabling Bing Search in Start Menu..."
Set-ItemProperty -Path "HKCU:\Software\Microsoft\Windows\CurrentVersion\Se arch" -Name "BingSearchEnabled" -Type DWord -Value 0
<#
Write-Host "Disabling Cortana"
Set-ItemProperty -Path "HKCU:\SOFTWARE\Microsoft\Windows\CurrentVersion\Se arch" -Name "CortanaConsent" -Type DWord -Value 0
If (!(Test-Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows\Windows Search")) {
New-Item -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows\Windows Search" -Force | Out-Null
}
#>
Write-Host "Hiding Search Box / Button..."
Set-ItemProperty -Path "HKCU:\Software\Microsoft\Windows\CurrentVersion\Se arch" -Name "SearchboxTaskbarMode" -Type DWord -Value 0

Write-Host "Removing Start Menu Tiles"

Set-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -Value '<LayoutModificationTemplate xmlns:defaultlayout="http://schemas.microsoft.com/Start/2014/FullDefaultLayout" xmlns:start="http://schemas.microsoft.com/Start/2014/StartLayout" Version="1" xmlns="http://schemas.microsoft.com/Start/2014/LayoutModification">'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <LayoutOptions StartTileGroupCellWidth="6" />'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <DefaultLayoutOverride>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <StartLayoutCollection>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <defaultlayout:StartLayout GroupCellWidth="6" />'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </StartLayoutCollection>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </DefaultLayoutOverride>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <CustomTaskbarLayoutCollection>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <defaultlayout:TaskbarLayout>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <taskbar:TaskbarPinList>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <taskbar:UWA AppUserModelID="Microsoft.MicrosoftEdge_8wekyb3d8bbwe!MicrosoftEdg e" />'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <taskbar:DesktopApp DesktopApplicationLinkPath="%APPDATA%\Microsoft\Windows\Start Menu\Programs\System Tools\File Explorer.lnk" />'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </taskbar:TaskbarPinList>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </defaultlayout:TaskbarLayout>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </CustomTaskbarLayoutCollection>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value '</LayoutModificationTemplate>'

$START_MENU_LAYOUT = @"
<LayoutModificationTemplate xmlns:defaultlayout="http://schemas.microsoft.com/Start/2014/FullDefaultLayout" xmlns:start="http://schemas.microsoft.com/Start/2014/StartLayout" Version="1" xmlns:taskbar="http://schemas.microsoft.com/Start/2014/TaskbarLayout" xmlns="http://schemas.microsoft.com/Start/2014/LayoutModification">
<LayoutOptions StartTileGroupCellWidth="6" />
<DefaultLayoutOverride>
<StartLayoutCollection>
<defaultlayout:StartLayout GroupCellWidth="6" />
</StartLayoutCollection>
</DefaultLayoutOverride>
</LayoutModificationTemplate>
"@

$layoutFile="C:\Windows\StartMenuLayout.xml"

#Delete layout file if it already exists
If(Test-Path $layoutFile)
{
Remove-Item $layoutFile
}

#Creates the blank layout file
$START_MENU_LAYOUT | Out-File $layoutFile -Encoding ASCII

$regAliases = @("HKLM", "HKCU")

#Assign the start layout and force it to apply with "LockedStartLayout" at both the machine and user level
foreach ($regAlias in $regAliases){
$basePath = $regAlias + ":\SOFTWARE\Policies\Microsoft\Windows"
$keyPath = $basePath + "\Explorer"
IF(!(Test-Path -Path $keyPath)) {
New-Item -Path $basePath -Name "Explorer"
}
Set-ItemProperty -Path $keyPath -Name "LockedStartLayout" -Value 1
Set-ItemProperty -Path $keyPath -Name "StartLayoutFile" -Value $layoutFile
}

#Restart Explorer, open the start menu (necessary to load the new layout), and give it a few seconds to process
Stop-Process -name explorer
Start-Sleep -s 5
$wshell = New-Object -ComObject wscript.shell; $wshell.SendKeys('^{ESCAPE}')
Start-Sleep -s 5

#Enable the ability to pin items again by disabling "LockedStartLayout"
foreach ($regAlias in $regAliases){
$basePath = $regAlias + ":\SOFTWARE\Policies\Microsoft\Windows"
$keyPath = $basePath + "\Explorer"
Set-ItemProperty -Path $keyPath -Name "LockedStartLayout" -Value 0

Write-Host "Search and Start Menu Tweaks Complete"
} # This was missing 12 July 2021
})

DocAElstein

11-25-2021, 12:12 PM

Coding for these Threads
https://eileenslounge.com/viewtopic.php?p=290229#p290229
https://excelfox.com/forum/showthread.php/2772-Some-Date-Notes-and-Tests

Option Explicit ' “Window"s is a name for a programming idea which might result in something we “see” as what we conceive as Windows. Manipulating of the actual “Windows” seems the key to pseudo “making my own” InputBox with range selection. Direct linked libraries (dll) are available to run as and when required, hence the wording of direct link: They are used as an efficient means to organise Microsoft’s software generally allowing different Applications to share smaller programs which are shipped as standard with the Microsoft Windows Operating system. They are however also available to programmers , programming the applications. They are usually contained in Folder with name similar to User 32. "API calls”: just means usually that you are using those things and related “Windows” concept-all gets gets bundled up in imprecise intimidating term API, for Application Programming interface
Public Declare Function APIsinUserDLL_MsgBox Lib "user32.dll" Alias "MessageBoxTimeoutA" (Optional ByVal hWnd As Long, Optional ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal uType As Long, Optional ByVal wLanguageID As Long, Optional ByVal Delay_ms As Long) As Long
Private Sub WhatsInMyGlobies() '
Dim WndNumber As Long
APIsinUserDLL_MsgBox hWnd:=WndNumber, Prompt:="Using DateSerial(2021, 12, 1) inside VBA will give" & vbCr & vbLf & vbCr & DateSerial(2021, 12, 1), Title:="NonModalPopUpThingy", uType:=4, wLanguageID:=0, Delay_ms:=5000 ' ' The error will occur if I do not have a pro open so the MsgBox line will error at ProWb.Name
End Sub
Sub MessinMitdates()
Rem 1 Attempt to get the sShortDate from registry via DateSerial( ) implification way
On Error GoTo Bed
Dim TestDateSerial As String
Let TestDateSerial = DateSerial(9, 3, 4) ' DateSerial(year, month, day) https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dateserial-function
' By experimenting, it appears that for the day and month, if the sShortDate in the registry needs more than one character then a zero is added to that retuned by DateSerial(9, 3, 4) For the year any missing characters seem to be relplaced by a 0 2 or 1 - For this reason I don't use 1 or 2 for the day or month becuse if i do , there may be some wrong determination below: We use the number to determine if we have a day or month or year
If InStr(1, TestDateSerial, "9", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Year in your short date format": Exit Sub
If InStr(1, TestDateSerial, "3", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Month number in your short date format": Exit Sub
If InStr(1, TestDateSerial, "4", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Day number in your short date format": Exit Sub
Dim C As Variant ' This is each character. It can be a number or letter, so I used Variant but string would work also
Dim Cnt As Long: Let Cnt = 1
Let C = Mid(TestDateSerial, Cnt, 1) ' ========= start of returned string
Do While IsNumeric(C) = True
Let Cnt = Cnt + 1 ' we are counting through the characters, (numbers), from the start, while we have a number. So we are counting the first number section
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = True
Dim Cnt1 As Long: Let Cnt1 = Cnt - 1 ' this will be the count of the characters ( numbers ) in the first number section
' =============================================
Dim Sep1 As String
Do While IsNumeric(C) = False
Let Sep1 = Sep1 & C ' In the first seperator
Let Cnt = Cnt + 1 ' we are counting through the character in the thing used as the first seperator. (These should not be numbers)
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = False
Dim DMY As String ' At this point we have reached the end of the first seperator,
' the next lines search the numbers in the first number section to determine if they are a day or month or year
If InStr(1, Left(TestDateSerial, Cnt - 1), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we are actually looking at the first number and first seperator, but never ming
If InStr(1, Left(TestDateSerial, Cnt - 1), "3", vbBinaryCompare) <> 0 Then Let DMY = "m"
If InStr(1, Left(TestDateSerial, Cnt - 1), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Dim sShortDate As String ' the next line gives us a character string where the fist numbers are replaced by characters representing if they are a day or month or year
Let sShortDate = Evaluate("=REPT(""" & DMY & """," & Cnt1 & ")") & Sep1 ' ======= make first bit of output ==
' ===== xx & sep1 ******************************************
Dim Pos2 As Long ' ================================================== ==========================================
Let Pos2 = Len(sShortDate) + 1 ' This should be the position where the second number section starts
Do While IsNumeric(C) = True
Let Cnt = Cnt + 1 ' we are counting the characters ( numbers ) in the second ( middle ) character ( number ) section
Let C = Mid(TestDateSerial, Cnt, 1)
Loop
Dim Cnt2 As Long: Let Cnt2 = Cnt - Pos2 ' this will be the count of the characters ( numbers ) in the second ( middle ) number section
' ========================== at first character in second seperator ========================================
Dim Sep2 As String
Do While IsNumeric(C) = False
Let Sep2 = Sep2 & C '
Let Cnt = Cnt + 1 ' we are counting through the characters making up the second seperator
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = False
' the Cnt C counting stops at the start of the last number section
' the next lines search the numbers in the second ( middle) number section to determine if they are a day or month or year
' at this point we have got the second seperator string, Sep2 and are at the start of the last number ===
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we are looking in the middle number section
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "3", vbBinaryCompare) <> 0 Then Let DMY = "m"
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Let sShortDate = sShortDate & Evaluate("=REPT(""" & DMY & """," & Cnt2 & ")") & Sep2 ' this adds to the sShortDate string the characters to indicate the type ( day month or year ) of the middle section numbers and the second seperator
' ==== xx & Sep1 & yy & Sep2 *******************************************
Dim Pos3 As Long: Let Pos3 = Len(sShortDate) + 1 ' this should be the start position of the last number section
Dim Cnt3 As Long '
Let Cnt3 = Len(TestDateSerial) - Pos3 + 1 ' this should be the number of characters ( numbers ) in the last number section
' we don't bother to loop through the last number section
' the next lines search the numbers in the third ( last ) number section to determine if they are a day or month or year
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we look from the start of the last number section, Pos3 , for a length of its count of its characters , Cnt3
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "3", vbBinaryCompare) <> 0 Then Let DMY = "m"
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Let sShortDate = sShortDate & Evaluate("=REPT(""" & DMY & """," & Cnt3 & ")") ' finally we add the characters representing the characters to indicate the type ( day month or year ) of the last section
' ===== xx & Sep1 & yy & Sep2 & zzz ************************************************** ***********************
' ================================================== ================================================== =========
GoTo Rem2
Bed: ' Error handling code section for if the above coding errored
Let sShortDate = "Error getting sShortDate"
On Error GoTo -1
Rem2: ' Rem 2 Some other computer and user info
On Error Resume Next ' In case info below is somehow protected
Dim UsrNme As String: Let UsrNme = Application.UserName: Let UsrNme = Environ("username")
Dim CmprNme As String: Let CmprNme = Environ("computername")
Dim WOS As String: Let WOS = Environ("OS")
Dim VersXl As String: Let VersXl = " ( " & ExcelVersion & " ) "
On Error GoTo 0
Rem 3 Shift a space for some info, and some formating
With Worksheets("Dates")
.Range("A1:B15").Insert , shift:=xlShiftDown
.Range("A1:B15").Clear
.Columns("A").Font.Size = 12
.Columns("A").ColumnWidth = 16
.Columns("B").Font.Size = 8
.Columns("B").ColumnWidth = 190
End With

With Worksheets("Dates").Range("A1:B1000")
.Item(1).Value = " " & UsrNme & " " & Format(Now(), "dddd, dd, mmm, yyyy. ") & Format(Now(), "hh") & "hr " & Right(Format(Now(), "hh mm"), 2) & "min" & " " & VersXl
.Item(3).Value = sShortDate: .Item(4).Value = " <---- " & CmprNme & " Registry sShortDate"
.Item(5).Value = DateSerial(2021, 12, 1): .Item(6).Value = "DateSerial(2021, 12, 1) for 1st dec 2021 was assigned to .Value of virgin cell. The .Value of the cell is returned as " & .Item(5).Value & " The .Value2 is returned as " & .Item(5).Value2 & ""
.Item(7).NumberFormat = "m/d/yyyy"
.Item(7).Value = DateSerial(2021, 12, 1): .Item(8) = "DateSerial(2021, 12, 1) for 1st Dec 2021 was assigned to .Value of cell formated in Short Date, using .NumberFormat = ""m/d/yyyy"" The .Value of the cell is " & .Item(7).Value & " The .Value2 is " & .Item(7).Value2 & ""
.Item(7).NumberFormat = "m/d/yyyy"
.Item(9).NumberFormat = "@"
.Item(9).Value = DateSerial(2021, 12, 1): .Item(10) = "DateSerial(2021, 12, 1) for 1st Dec 2021 was assigned to .Value of cell formated in Text, using .NumberFormat = ""@"" The .Value of the cell is " & .Item(9).Value & " The .Value2 is " & .Item(9).Value2 & ""
.Item(9).NumberFormat = "@"
Dim DteSerial As String: Let DteSerial = DateSerial(2021, 12, 1)
.Item(11).Value = DteSerial: .Item(12).Value = "I have not done anything to the format of the cell, its a virgin cell, but I first put what came from DateSerial(2021, 12, 1) into a string variable, DteSerial , and then asigned that string variable to the cell .Value The .Value of the cell is " & .Item(11).Value & " The .Value2 is " & .Item(11).Value2 & ""
.Item(13).NumberFormat = "m/d/yyyy"
.Item(13).Value = DteSerial: .Item(14).Value = "The cell is formattted as short date format using .NumberFormat = ""m/d/yyyy"" I am assigning the filled variable Dteserial to it. The .Value of the cell is " & .Item(13).Value & " the .Value2 is " & .Item(13).Value2 & ""
.Item(13).NumberFormat = "m/d/yyyy"

' Say in a self cancelling meassage box what the DateSerial(2021, 12, 1) returns in VBA
Dim WndNumber As Long:
APIsinUserDLL_MsgBox hWnd:=WndNumber, Prompt:="Using DateSerial(2021, 12, 1) inside VBA will give" & vbCr & vbLf & vbCr & DateSerial(2021, 12, 1), Title:="This will close itself after a few seconds", uType:=4, wLanguageID:=0, Delay_ms:=4000 ' ' The error will occur if I do not have a pro open so the MsgBox line will error at ProWb.Name
DoEvents: DoEvents
.Item(17).Value2 = 44531: .Item(17).NumberFormat = "m/d/yyyy": .Item(18).Value = "a .Value2 of 44531(this is the Excel number for 1stDec,2021) was put in a virgin cell, which then was given the cell format of Short Date, using .NumberFormat = ""m/d/yyyy"" "
.Item(19).Value2 = 44531: .Item(19).NumberFormat = "m\/d\/yyyy": .Item(20).Value = "a .Value2 of 44531 was put in a virgin cell, which then was given the cell format of .NumberFormat = ""m\/d\/yyyy"" "
.Item(21).Value = Format("12 1 2021", "dd_mm_yyyy"): .Item(22).Value = "For a virgin cell I assigned like this .Item(21).Value = Format(""12 1 2021"", ""dd_mm_yyyy"") The .Value frtom the cell is " & .Item(21).Value & " and the .Value2 is " & .Item(21).Value2 & ""
.Item(23).Value = Format(#12/1/2021#, "dd_mm_yyyy"): .Item(24).Value = "For a virgin cell I tried to assign this .Item(23).Value = Format(#12 - 1 .2021#, ""dd_mm_yyyy"") m When I hit Enter I did not get any error, but that was changed to Format(#12/1/2021#, ""dd_mm_yyyy"") What seems to be happeming there is that Excel tries to coerce the string inside a # pair into the standard English American format. So it sees #12/1/2021# as December 1st, 2021 and gives me the date in the format I ask for. The .Value from the cell is " & .Item(23).Value & " and the .Value2 is " & .Item(23).Value2 & ""
.Item(25).Value = Format(#12/1/2021#, "m/d/yyyy"): .Item(26).Value = "For a virgin cell I assigned .Item(25).Value = Format(#12/1/2021#, ""m/d/yyyy"") The .Value from the cell is " & .Item(25).Value & " and the .Value2 is " & .Item(25).Value2 & ""
.Item(27).Value = Format(#12/1/2021#, "m\/d\/yyyy"): .Item(28).Value = "For a virgin cell I assigned .Item(27).Value = Format(#12/1/2021#, ""m\/d\/yyyy"") The .Value from the cell is " & .Item(27).Value & " and the .Value2 is " & .Item(27).Value2 & ""
End With
'_________________________________________________ __________________________________________________ ___________

ThisWorkbook.Save

End Sub
' From Rory's A Tool
Public Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case CLng(Val(Application.Version))
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "Excel 2016 (Mac)"
Case Else: temp = "Unknown"
End Select
#Else
Select Case CLng(Val(Application.Version))
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case 16: temp = "Excel 2016, 2019 0r 365 (Windows)"
Case Else: temp = "Unknown"
End Select
#End If
#If Win64 Then
temp = temp & " 64 bit"
#Else
temp = temp & " 32 bit"
#End If
Let ExcelVersion = temp
End Function

DocAElstein

12-06-2021, 02:49 PM

In support of this Thread post
https://eileenslounge.com/viewtopic.php?p=290499#p290499

Method a)
This is the way you do it, just in case it is more successful in the future for anything else .
I use here the example of what you are looking for. As you can see, we almost get there, but just crap out at the very last step :(

_1 Go to the Site of the search/ archive engine, web archive org - http://web.archive.org/
That should bring up their “WayBackMachine”
https://i.postimg.cc/XYB2tJgs/Site-web-archive-org.jpg

_ 2 Put that link given from the book in the search bar of their “WayBackMachine”
https://i.postimg.cc/RVFpQGJ5/Put-link-in-search-bar.jpg
3785

_3 Hit Enter
You will then see something like this if it found anything.
https://i.postimg.cc/DZxTzgMv/Lots-of-captures-by-arcaive-Bot.jpg
In this case it seems to have found a lot, - so at this stage it looks very hopeful

_ 4 Pick one of the years where there are hits shown . That is just guess work – try to think of a year that what you are looking for may have been available. In this next screen shot I chose randomly the year 2003
https://i.postimg.cc/ZYjDdXRx/Chose-2003-It-had-a-few-hits-in-it.jpg
Now you will see the dates ringed.
https://i.postimg.cc/q781M5Sn/Ringed-dates-of-when-capture-was-done.jpg
Those are the dates on which the search/ archive engine, web org, made a random capture of the web site

_ 5 Hover over any of them there ringed dates, and click on a time shown
https://i.postimg.cc/hvCyRQw5/Pick-a-date-and-time.jpg
3786

_6 After this you have to take it as it comes and see how far you get.
In this example, I got this, and noticed a link to Examples :
https://i.postimg.cc/3wMLhTSY/Examples-1.jpg
On another attempt after picking a different time and date I got something different but once again found a link to the examples.
https://i.postimg.cc/ncPRd7qs/Examples-2.jpg
3787

When I clicked on either of those links I see this, which is still looking hopeful: We are almost there.
https://i.postimg.cc/mkZXnyd9/Almost-there.jpg
3788

Unfortunately, every attempt so far by me craps out when I hit that zip link
https://i.postimg.cc/PxQVKRMh/Craps-out-at-the-last-attempt.jpg
3789

I tried a couple of dozen times, and so far it always craps out at the last step. Shame we almost got there- I would take a guess that you won’t find the file this way. When I tried the same with the examples for the Excel book, I got the file on about every second attempt.
As I mentioned it’s a bits hit and miss.
I will look again randomly today when I have a few minutes and let you know if I strike lucky. But I don’t hold out much hope in this case.
Always worth a try. More times than not the web archive works for me. I often use it when passing a link to a current web site and pass the link to the archived stored capture in preference to the actual link because then I know they get what I want them to get. Its invaluable for example, for Microsoft links, since they seem to have nothing better to do then change what actually appears at their help links, some times for the better, sometimes for the worse.

Edit
Method b) Frantic net search

Examples.zip - https://app.box.com/s/w75bf0yb8dv875u0myyyg6xxmr9csiw3
RomanWortdBook.dot - https://app.box.com/s/t09e5w0hrr71slos3tlnb5ds9byw5s3p
BobsdBook.doc - https://app.box.com/s/2wwnfuxupruw8jzfmlhlown9trv8yx3t

DocAElstein

12-13-2021, 04:36 PM

In support of this Thread
http://www.eileenslounge.com/viewtopic.php?f=41&t=37540

These were the simple steps:
_ Start at free personal account page,( I did give you before ( https://www.box.com/pricing/individual
https://i.postimg.cc/dtqHX8z3/Choose-free-personal.jpg
https://account.box.com/signup/personal?tc=annual ) )

_ https://i.postimg.cc/vTg6c2KX/box-join-Name-EMail-box-password.jpg
You may have some errors if you do not check all boxes
https://i.postimg.cc/W34ZP16B/error-europe-box-join-Name-EMail-box-password.jpg
https://i.postimg.cc/0yxCrmYm/error2-europe-box-join-Name-EMail-box-password.jpg

_ With all boxes checked , it should be successful
https://i.postimg.cc/nLp70ksc/box-join-sucess-Name-EMail-box-password.jpg

_ by a successful registration, a confirmation Email will be sent to your given Email address
https://i.postimg.cc/RhFLGTDn/They-send-you-an-EMail-confirmation.jpg

The confirmation should arrive at your given Email address, but note it might arrive in spam folder sometimes
https://i.postimg.cc/mZXwk0P3/box-confirmation-may-arrive-in-spam.jpg

_ You must click to confirm your registration
https://i.postimg.cc/x1KMv714/box-confirmation-Verify-EMail.jpg

( _ sometime you may receive a warning from your Email provider, but not always
https://i.postimg.cc/Wzh001dG/box-confirmation-Verify-EMail-Warning.jpg )

_ After you confirmation you should arrive at box login
https://i.postimg.cc/FFdp6hFf/Arrived-at-box-Log-in-page.jpg

_ To login .. first Email address
https://i.postimg.cc/m2n8X0RZ/box-Log-in-EMail.jpg
, then password
https://i.postimg.cc/wjS4vnb4/box-Log-in-password.jpg

_ If all has gone well, you now are logged in to your new account, and can begin using
https://i.postimg.cc/76qVJ419/box-Log-Sucess.jpg

That’s it! You have an account!
_._______________

_ Because I already know all about using, I did skip introduction and set up. But you may chose not to do that
https://i.postimg.cc/Nfs3vhW1/Skipped-Set-up.jpg

_._____________________-

Example Upload and get share link
_New File(s) upload
https://i.postimg.cc/VNqgNvt5/Test-upload-New-File.jpg

( _ you can upload many files at once
https://i.postimg.cc/PrJSMdgF/Upload-many-files-at-once.jpg )

The files will be uploaded
https://i.postimg.cc/ydKfhcKF/Files-will-be-uploaded.jpg
https://i.postimg.cc/HLXZ73qY/All-Files-are-uploaded.jpg

_ I can get a share link quickly
https://i.postimg.cc/YqDscvNH/I-can-get-quick-share-link.jpg

_ I click to copy share link into my clipboard
https://i.postimg.cc/hGQFZ9N6/Copy-share-link-to-Clipboard.jpg

Now that share link is in my clipboard

So finally you have the share link for that File, and can paste it any where
Here is that link:
https://app.box.com/s/gac9uzmfeudlo37hsj4hfim5wb7e3l3z

The peson with that share link can click on it.
Then they will see it and/ or can download it
https://i.postimg.cc/VspVYmYt/I-can-see-it-I-can-download-it.jpg

Alan

Alan

_._____________________-

P.S. For Image posting share links I also use https://postimages.org/
This does not need any registering. I do use this have for example, for all the image links I did use here.

_ start here: https://postimages.org/
_ https://i.postimg.cc/GtNWPKjX/postimages.jpg

_ Select one or more files to upload https://i.postimg.cc/vZwjQc2x/postimages-select-files.jpg

Files will be uploaded
https://i.postimg.cc/MK1wbkhR/post-images.jpg
https://i.postimg.cc/nhKWMpNR/post-images.jpg

_ you can select what type of link you want
https://i.postimg.cc/SsbjdLgN/post-images-uploaded-links-available.jpg

Finally all links are available for you to copy
https://i.postimg.cc/9zHh51qr/post-images-uploaded-links-available.jpg

DocAElstein

01-01-2022, 03:39 PM

In support of this Thread https://excelfox.com/forum/showthread.php/2774-Summarize-Data-from-Dates-to-Months-based-on-Criteria
https://excelfox.com/forum/showthread.php/2774-Summarize-Data-from-Dates-to-Months-based-on-Criteria
https://i.postimg.cc/14gZ3Xtb/Case-Tracker.jpg (https://postimg.cc/14gZ3Xtb)
_____ Workbook: Project Tracker.xlsx ( Using Excel 2007 32 bit )
Row\ColBCD
2DATECONTRACT NO.STATUS

3 01-Jul-21NOT STARTED

4 01-Aug-21IN PROGRESS

5 02-Aug-21COMPLETE

6 09-Sep-21ON HOLD

7 21-Oct-21NOT STARTED

8 22-Oct-21IN PROGRESS

9 03-Nov-21COMPLETE

10 05-Nov-21ON HOLD

11 12-Dec-21COMPLETE

12 22-Dec-21ON HOLD
Worksheet: Case Tracker

https://i.postimg.cc/H87GZZRT/Summary.jpg (https://postimg.cc/H87GZZRT)
_____ Workbook: Project Tracker.xlsx ( Using Excel 2007 32 bit )
Row\ColBCDEF
2DATENOT STARTEDIN PROGRESSON HOLDCOMPLETE

3 Aug-21

4 Sep-21

5 Oct-21

6 Nov-21

7 Dec-21

8 Jan-22

9 Feb-22

10 Mar-22

11 Apr-22

12 May-22

13 Jun-22

14 Jul-22

15 Aug-22

16 Sep-22

17 Oct-22

18 Nov-22

19 Dec-22
Worksheet: Summary

results after running macro here https://excelfox.com/forum/showthread.php/2774-Summarize-Data-from-Dates-to-Months-based-on-Criteria?p=16306&viewfull=1#post16306 https://excelfox.com/forum/showthread.php/2774-Summarize-Data-from-Dates-to-Months-based-on-Criteria?p=16306&viewfull=1#post16306
_____ Workbook: Project Tracker.xls ( Using Excel 2007 32 bit )
Row\ColBCDEF
2DATENOT STARTEDIN PROGRESSON HOLDCOMPLETE

3 Aug-211 1

4 Sep-211

5 Oct-2111

6 Nov-211 1

7 Dec-211 1

8 Jan-22

9 Feb-22

10 Mar-22

11 Apr-22

12 May-22

13 Jun-22

14 Jul-22

15 Aug-22

16 Sep-22

17 Oct-22

18 Nov-22

19 Dec-22
Worksheet: Summary

DocAElstein

02-06-2022, 07:26 PM

In support of the forum post:

NOT POSTED YET – DRAFT COPY

Hi
I am new to PowerShell script since a few weeks

I hit my first major coding problem, I have got over some smaller ones.

I have a GUI with lots of buttons on it. Each Button has some various things behind it. Some do some quite major things to the computer, such as registry changes, others download stuff. With one exception all is working as it should**.

Problem Summary

This coding does what it should. I checked it on a few computers with different Windows 10 versions. It checks for installed winget (https://de.wikipedia.org/wiki/Windows_Package_Manager) on the computer, and if not there attempts to download it. ( That download might not work for other reasons, but that is a separate issue which I am not concerned with here – as it happens I have it installed on all my computers )
On all my current computers that have winget, the message comes up saying 'winget already installed', and the coding moves on. All is well

Write-Host "Checking winget..."
if (Test-Path ~\AppData\Local\Microsoft\WindowsApps\winget.exe){ # Check if winget is installed
'Winget Already Installed'
}
else{
# Installing winget from the Microsoft Store
Write-Host "Winget not found, installing it now."
$ResultText.text = "`r`n" +"`r`n" + "Installing Winget... Please Wait"
Start-Process "ms-appinstaller:?source=https://aka.ms/getwinget" # If I paste that link in Browser URL I get this offered as if I hit the download button somewhere Microsoft.DesktopAppInstaller_8wekyb3d8bbwe.msixbu ndle
$nid = (Get-Process AppInstaller).Id
Wait-Process -Id $nid
Write-Host Winget Installed
$ResultText.text = "`r`n" +"`r`n" + "Winget Installed - Ready for Next Task"
} # })

I put that same coding behind a button on a GUI. It seems to work initially, the GUI comes up,
https://i.postimg.cc/xJ3g9CzX/GUI-comes-up.jpg (https://postimg.cc/xJ3g9CzX)
, and on clicking the button it appears initially to start OK, , but on the same computers, the coding always hangs at
"checking winget…"

#
Add-Type -AssemblyName System.Windows.Forms
# Create a new form
$Form = New-Object system.Windows.Forms.Form
# Define the size
$Form.ClientSize = '800, 600'

# Range to put button in
$Panel10 = New-Object system.Windows.Forms.Panel ; $Panel10.height = 50 ; $Panel10.width = 250 ; $Panel10.location = New-Object System.Drawing.Point(1, 25)

# function to create sinple botton
function Create-Button {param([string]$Text, [int]$FntSz, [int]$Width, [int]$Height, [int]$ClmX, [int]$RwY)#As Object ' This function allows us to make a buttons in one line. (Those later single lines do not make the button appear)
$Btn = New-Object System.Windows.Forms.Button #
$Btn.Text = $Text #
$Btn.Width = $Width ; $Btn.Height = $Height #
#
$Btn.Location = New-Object System.Drawing.Point($ClmX, $RwY) #
$Btn.Font = New-Object System.Drawing.Font('Arial', $FntSz) # ('Microsoft Sans Serif', 9)
#
return $Btn } #
# Make button
$GetWinGet = Create-Button -Text "winget" -FntSz 9 -Width 117 -Height 21 -ClmX 3 -RwY 1

$GetWinGet.Add_Click({
Write-Host "Checking winget..." # PROBLEM!!!! This wont work in a button - it freezes here?
if (Test-Path ~\AppData\Local\Microsoft\WindowsApps\winget.exe){ # Check if winget is installed
'Winget Already Installed'
}
else{
# Installing winget from the Microsoft Store
Write-Host "Winget not found, installing it now."
$ResultText.text = "`r`n" +"`r`n" + "Installing Winget... Please Wait"
Start-Process "ms-appinstaller:?source=https://aka.ms/getwinget" # If I paste that link in Browser URL I get this offered as if I hit the download button somewhere Microsoft.DesktopAppInstaller_8wekyb3d8bbwe.msixbu ndle
$nid = (Get-Process AppInstaller).Id
Wait-Process -Id $nid
Write-Host Winget Installed
$ResultText.text = "`r`n" +"`r`n" + "Winget Installed - Ready for Next Task"
} })

# Add Button to range
$Panel10.controls.AddRange(@($GetWinGet))

# Add ranbge to Form
$Form.controls.AddRange(@($Panel10))

# Display the form
[void]$Form.ShowDialog()

On this same GUI I can put lots of other buttons, all doing different things, and they always do what they should**

What am I missing?

Alan

DocAElstein

02-06-2022, 07:32 PM

Test

#
Add-Type -AssemblyName System.Windows.Forms
# Create a new form
$Form = New-Object system.Windows.Forms.Form
# Define the size, title and background color
$Form.ClientSize = '800, 600'

# Range to put button in
$Panel10 = New-Object system.Windows.Forms.Panel ; $Panel10.height = 50 ; $Panel10.width = 250 ; $Panel10.location = New-Object System.Drawing.Point(1, 25)

# function to create sinple botton
function Create-Button {param([string]$Text, [int]$FntSz, [int]$Width, [int]$Height, [int]$ClmX, [int]$RwY)#As Object ' This function allows us to make a buttons in one line. (Those later single lines do not make the button appear)
$Btn = New-Object System.Windows.Forms.Button #
$Btn.Text = $Text #
$Btn.Width = $Width ; $Btn.Height = $Height #
#
$Btn.Location = New-Object System.Drawing.Point($ClmX, $RwY) #
$Btn.Font = New-Object System.Drawing.Font('Arial', $FntSz) # ('Microsoft Sans Serif', 9)
#
return $Btn } #
# Make button
$GetWinGet = Create-Button -Text "winget" -FntSz 9 -Width 117 -Height 21 -ClmX 3 -RwY 1 # $firefox.width = 212

$GetWinGet.Add_Click({
Write-Host "Checking winget..." # PROBLEM!!!! This wont work in a button - it freezes here?
if (Test-Path ~\AppData\Local\Microsoft\WindowsApps\winget.exe){ # Check if winget is installed
'Winget Already Installed'
}
else{
# Installing winget from the Microsoft Store
Write-Host "Winget not found, installing it now."
$ResultText.text = "`r`n" +"`r`n" + "Installing Winget... Please Wait"
Start-Process "ms-appinstaller:?source=https://aka.ms/getwinget" # If I paste that link in Browser URL I get this offered as if I hit the download button somewhere Microsoft.DesktopAppInstaller_8wekyb3d8bbwe.msixbu ndle #$vscode.width = 211
$nid = (Get-Process AppInstaller).Id
Wait-Process -Id $nid
Write-Host Winget Installed
$ResultText.text = "`r`n" +"`r`n" + "Winget Installed - Ready for Next Task"
} })

# Add Button to range
$Panel10.controls.AddRange(@($GetWinGet))

# Add ranbge to Form
$Form.controls.AddRange(@($Panel10))

# Display the form
[void]$Form.ShowDialog()

#
Add-Type -AssemblyName System.Windows.Forms
# Create a new form
$Form = New-Object system.Windows.Forms.Form
# Define the size, title and background color
$Form.ClientSize = '800, 600'

# Range to put button in
$Panel10 = New-Object system.Windows.Forms.Panel ; $Panel10.height = 50 ; $Panel10.width = 250 ; $Panel10.location = New-Object System.Drawing.Point(1, 25)

# function to create sinple botton
function Create-Button {param([string]$Text, [int]$FntSz, [int]$Width, [int]$Height, [int]$ClmX, [int]$RwY)#As Object ' This function allows us to make a buttons in one line. (Those later single lines do not make the button appear)
$Btn = New-Object System.Windows.Forms.Button #
$Btn.Text = $Text #
$Btn.Width = $Width ; $Btn.Height = $Height #
#
$Btn.Location = New-Object System.Drawing.Point($ClmX, $RwY) #
$Btn.Font = New-Object System.Drawing.Font('Arial', $FntSz) # ('Microsoft Sans Serif', 9)
#
return $Btn } #
# Make button
$GetWinGet = Create-Button -Text "winget" -FntSz 9 -Width 117 -Height 21 -ClmX 3 -RwY 1 # $firefox.width = 212

$GetWinGet.Add_Click({
Write-Host "Checking winget..." # PROBLEM!!!! This wont work in a button - it freezes here?
if (Test-Path ~\AppData\Local\Microsoft\WindowsApps\winget.exe){ # Check if winget is installed
'Winget Already Installed'
}
else{
# Installing winget from the Microsoft Store
Write-Host "Winget not found, installing it now."
$ResultText.text = "`r`n" +"`r`n" + "Installing Winget... Please Wait"
Start-Process "ms-appinstaller:?source=https://aka.ms/getwinget" # If I paste that link in Browser URL I get this offered as if I hit the download button somewhere Microsoft.DesktopAppInstaller_8wekyb3d8bbwe.msixbu ndle #$vscode.width = 211
$nid = (Get-Process AppInstaller).Id
Wait-Process -Id $nid
Write-Host Winget Installed
$ResultText.text = "`r`n" +"`r`n" + "Winget Installed - Ready for Next Task"
} })

# Add Button to range
$Panel10.controls.AddRange(@($GetWinGet))

# Add ranbge to Form
$Form.controls.AddRange(@($Panel10))

# Display the form
[void]$Form.ShowDialog()

DocAElstein

02-08-2022, 09:29 PM

In support of this forum post
https://excelfox.com/forum/showthread.php/2783-User-Form-entry-in-a-second-sheet-need-help-with-VBA-code?p=16373&viewfull=1#post16373

_____ Workbook: Work_file.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHI
1S.No.YearMonthNameProjectTaskAmountSubmitted By

2
1
2022JanuarybbbProject2Task2
100Liviu Popescu

3
2
2022FebruarycccProject5Task1
200Liviu Popescu

4
3
2022MarchaaaProject3Task2
500Liviu Popescu

5
Worksheet: Database

_____ Workbook: Work_file.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFG
1NameProjectTask
01-22
02-22
03-22
04-22

2aaaProject1Task1

3aaaProject1Task2

4aaaProject2Task1

5aaaProject2Task2

6aaaProject3Task1

7aaaProject3Task2

8aaaProject4Task1

9aaaProject4Task2

10aaaProject5Task1

11aaaProject5Task2

12bbbProject1Task1

13bbbProject1Task2

14bbbProject2Task1

15bbbProject2Task2

16bbbProject3Task1

17bbbProject3Task2

18bbbProject4Task1

19bbbProject4Task2

20bbbProject5Task1

21bbbProject5Task2

22cccProject1Task1

23cccProject1Task2

24cccProject2Task1

25cccProject2Task2

26cccProject3Task1

27cccProject3Task2

28cccProject4Task1

29cccProject4Task2

30cccProject5Task1

31cccProject5Task2

32dddProject1Task1

33dddProject1Task2
Worksheet: Database1

DocAElstein

02-08-2022, 09:29 PM

In support of this forum post
https://excelfox.com/forum/showthread.php/2783-User-Form-entry-in-a-second-sheet-need-help-with-VBA-code?p=16376&viewfull=1#post16376

Before, as we had before

_____ Workbook: Work_file.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFGHI
1S.No.YearMonthNameProjectTaskAmountSubmitted By

2
1
2022JanuarybbbProject2Task2
100Liviu Popescu

3
2
2022FebruarycccProject5Task1
200Liviu Popescu

4
3
2022MarchaaaProject3Task2
500Liviu Popescu

5
Worksheet: Database

_____ Workbook: Work_file.xlsm ( Using Excel 2007 32 bit )
Row\ColABCDEFG
1NameProjectTask
01-22
02-22
03-22
04-22

2aaaProject1Task1

3aaaProject1Task2

4aaaProject2Task1

5aaaProject2Task2

6aaaProject3Task1

7aaaProject3Task2

8aaaProject4Task1

9aaaProject4Task2

10aaaProject5Task1

11aaaProject5Task2

12bbbProject1Task1

13bbbProject1Task2

14bbbProject2Task1

15bbbProject2Task2

16bbbProject3Task1

17bbbProject3Task2

18bbbProject4Task1

19bbbProject4Task2

20bbbProject5Task1

21bbbProject5Task2

22cccProject1Task1

23cccProject1Task2

24cccProject2Task1

25cccProject2Task2

26cccProject3Task1

27cccProject3Task2

28cccProject4Task1

29cccProject4Task2

30cccProject5Task1

31cccProject5Task2

32dddProject1Task1

33dddProject1Task2
Worksheet: Database1

DocAElstein

02-08-2022, 09:29 PM

In support of this forum post
https://excelfox.com/forum/showthread.php/2783-User-Form-entry-in-a-second-sheet-need-help-with-VBA-code?p=16376&viewfull=1#post16376

After

_____ Workbook: Work_file.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1NameProjectTask
01-22
02-22
03-22
04-22

2aaaProject1Task1

3aaaProject1Task2

4aaaProject2Task1

5aaaProject2Task2

6aaaProject3Task1

7aaaProject3Task2
500

8aaaProject4Task1

9aaaProject4Task2

10aaaProject5Task1

11aaaProject5Task2

12bbbProject1Task1

13bbbProject1Task2

14bbbProject2Task1

15bbbProject2Task2
100

16bbbProject3Task1

17bbbProject3Task2

18bbbProject4Task1

19bbbProject4Task2

20bbbProject5Task1

21bbbProject5Task2

22cccProject1Task1

23cccProject1Task2

24cccProject2Task1

25cccProject2Task2

26cccProject3Task1

27cccProject3Task2

28cccProject4Task1

29cccProject4Task2

30cccProject5Task1
200

31cccProject5Task2

32dddProject1Task1
Worksheet: Database1

DocAElstein

02-08-2022, 09:29 PM

In support of this forum post
https://excelfox.com/forum/showthread.php/2783-User-Form-entry-in-a-second-sheet-need-help-with-VBA-code?p=16376&viewfull=1#post16376

After

_____ Workbook: Work_file.xlsm ( Using Excel 2007 32 bit )
Row\Col
A
B
C
D
E
F
G

1NameProjectTask
01-22
02-22
03-22
04-22

2aaaProject1Task1

3aaaProject1Task2

4aaaProject2Task1

5aaaProject2Task2

6aaaProject3Task1

7aaaProject3Task2
500

8aaaProject4Task1

9aaaProject4Task2

10aaaProject5Task1

11aaaProject5Task2

12bbbProject1Task1

13bbbProject1Task2

14bbbProject2Task1

15bbbProject2Task2
100

16bbbProject3Task1

17bbbProject3Task2

18bbbProject4Task1

19bbbProject4Task2

20bbbProject5Task1

21bbbProject5Task2

22cccProject1Task1

23cccProject1Task2

24cccProject2Task1

25cccProject2Task2

26cccProject3Task1

27cccProject3Task2

28cccProject4Task1

29cccProject4Task2

30cccProject5Task1
200

31cccProject5Task2

32dddProject1Task1
Worksheet: Database1

DocAElstein

02-09-2022, 07:58 PM

In support of these forum posts
https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776
https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
https://eileenslounge.com/viewtopic.php?f=18&t=37740
https://eileenslounge.com/viewtopic.php?f=18&t=37712
https://eileenslounge.com/viewtopic.php?f=18&t=37707

'Version : 5.1.19041.1320
'InstanceId : e165cf30-9ddd-49ed-96c7-59cca98516ee
'UI: System.Management.Automation.Internal.Host.Interna lHostUserInterface
'CurrentCulture: DE -DE
'CurrentUICulture: DE -DE
'PrivateData: Microsoft.PowerShell.Host.ISE.ISEOptions
'DebuggerEnabled : True
'IsRunspacePushed : False
'Runspace: System.Management.Automation.Runspaces.LocalRunspa ce
'https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776
'https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
'https://eileenslounge.com/viewtopic.php?f=18&t=37740
'https://eileenslounge.com/viewtopic.php?f=18&t=37712
'https://eileenslounge.com/viewtopic.php?f=18&t=37707
Sub Services() ' https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776 https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
' PowerShell
Dim PScmdLet As String, cmdLet As String
'Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\acer\Desktop\test.txt' -Width 1000"
Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath '" & ThisWorkbook.Path & Application.PathSeparator & "test.txt' -Width 1000"
Let PScmdLet = "powershell -command " & cmdLet ' https://www.devhut.net/vba-run-powershell-command/
CreateObject("WScript.Shell").Exec (PScmdLet)
' Get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "test.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundamental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot receives it has to be a string of exactly the right length
Get #FileNum, , TotalFile 'Debug.Print TotalFile
Let TotalFile = Replace(TotalFile, Chr(0), "", 1, -1, vbBinaryCompare) ' There seems to be a lot of Chr(0)s in the string https://i.postimg.cc/t43HCQr9/Rather-a-lot-of-Chr-0-s.jpg
'Let TotalFile = Replace(TotalFile, Chr(255) & Chr(254) & vbCr & vbLf, "", 1, 1, vbBinaryCompare) ' this would tsake the first bit of crap out, (alternatively we can just take out the first line when split later by
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

' make a 1 D array of the text file lines
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)

' make array for output
Dim arrOut() As String: ReDim arrOut(1 To UBound(arrRws()) - 2, 1 To 3) ' we are ignoring the first 3 lines. The UBound of the 1 dimensional array is already 1 less then the lines we need because a 1 dimensional array starts at 0
Dim Cnt As Long
For Cnt = 1 To UBound(arrRws()) - 2
If arrRws(Cnt + 2) = "" Then
' This should occur at the last empty rows, so we could consider jumping out of the loop here
Else
' time to split the line string
Dim Pos1 As Long: Let Pos1 = InStr(1, arrRws(Cnt + 2), " ", vbBinaryCompare)
Dim Nme As String: Let Nme = Left(arrRws(Cnt + 2), Pos1 - 1)
Dim Pos3 As Long: Let Pos3 = Len(arrRws(Cnt + 2)) - InStrRev(arrRws(Cnt + 2), " ", -1, vbBinaryCompare)
Dim StrtTyp As String: Let StrtTyp = Right(arrRws(Cnt + 2), Pos3)
Dim DispNme As String: Let DispNme = Replace(arrRws(Cnt + 2), Nme, "", 1, -1, vbBinaryCompare)
Let DispNme = Replace(DispNme, StrtTyp, "", 1, -1, vbBinaryCompare)
Let DispNme = Trim(DispNme)
' fill the array for output
Let arrOut(Cnt, 1) = Nme: arrOut(Cnt, 2) = DispNme: arrOut(Cnt, 3) = StrtTyp
End If

Next Cnt

' Chuck array into a spreadsheet
Let ThisWorkbook.Worksheets("PowerShell").Range("A2").Resize(UBound(arrOut(), 1), 3).Value = arrOut()
ThisWorkbook.Worksheets("PowerShell").Cells.Columns("A:C").EntireColumn.AutoFit

End Sub

Edit Some issues…
I messed up with a few things.
_ the display name could be long and go up to the startuptype in the text file, which messed up the manipulation of a line of data from the text file a bit. For now I fiddled that by adding some spaces before the words used for the startuptype. A better solution will probably wait until I fully understand the PowerShell code line
_ There seems to be some strange effects with something somewhere working too slow, too fast or not giving accurate information about if a text file is present. For now that is fiddled with some Waits , Dirs and a Kill. That will do for now, but that need to be looked at again when I understand better wots going on

The next code version is in the next post
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=16369&viewfull=1#post16369

DocAElstein

02-09-2022, 07:58 PM

In support of these forum posts
https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776
https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
https://eileenslounge.com/viewtopic.php?f=18&t=37740
https://eileenslounge.com/viewtopic.php?f=18&t=37712
https://eileenslounge.com/viewtopic.php?f=18&t=37707

'Version : 5.1.19041.1320
'InstanceId : e165cf30-9ddd-49ed-96c7-59cca98516ee
'UI: System.Management.Automation.Internal.Host.Interna lHostUserInterface
'CurrentCulture: DE -DE
'CurrentUICulture: DE -DE
'PrivateData: Microsoft.PowerShell.Host.ISE.ISEOptions
'DebuggerEnabled : True
'IsRunspacePushed : False
'Runspace: System.Management.Automation.Runspaces.LocalRunspa ce
'https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776
'https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
'https://eileenslounge.com/viewtopic.php?f=18&t=37740
'https://eileenslounge.com/viewtopic.php?f=18&t=37712
'https://eileenslounge.com/viewtopic.php?f=18&t=37707
Sub Services() ' https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776 https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
' PowerShell
Dim PScmdLet As String, cmdLet As String
'Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\acer\Desktop\test.txt' -Width 1000"
Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath '" & ThisWorkbook.Path & Application.PathSeparator & "test.txt' -Width 1000"
Let PScmdLet = "powershell -command " & cmdLet ' https://www.devhut.net/vba-run-powershell-command/
CreateObject("WScript.Shell").Exec (PScmdLet)
' Get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "test.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundamental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot receives it has to be a string of exactly the right length
Get #FileNum, , TotalFile 'Debug.Print TotalFile
Let TotalFile = Replace(TotalFile, Chr(0), "", 1, -1, vbBinaryCompare) ' There seems to be a lot of Chr(0)s in the string https://i.postimg.cc/t43HCQr9/Rather-a-lot-of-Chr-0-s.jpg
'Let TotalFile = Replace(TotalFile, Chr(255) & Chr(254) & vbCr & vbLf, "", 1, 1, vbBinaryCompare) ' this would tsake the first bit of crap out, (alternatively we can just take out the first line when split later by
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

' make a 1 D array of the text file lines
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)

' make array for output
Dim arrOut() As String: ReDim arrOut(1 To UBound(arrRws()) - 2, 1 To 3) ' we are ignoring the first 3 lines. The UBound of the 1 dimensional array is already 1 less then the lines we need because a 1 dimensional array starts at 0
Dim Cnt As Long
For Cnt = 1 To UBound(arrRws()) - 2
If arrRws(Cnt + 2) = "" Then
' This should occur at the last empty rows, so we could consider jumping out of the loop here
Else
' time to split the line string
Dim Pos1 As Long: Let Pos1 = InStr(1, arrRws(Cnt + 2), " ", vbBinaryCompare)
Dim Nme As String: Let Nme = Left(arrRws(Cnt + 2), Pos1 - 1)
Dim Pos3 As Long: Let Pos3 = Len(arrRws(Cnt + 2)) - InStrRev(arrRws(Cnt + 2), " ", -1, vbBinaryCompare)
Dim StrtTyp As String: Let StrtTyp = Right(arrRws(Cnt + 2), Pos3)
Dim DispNme As String: Let DispNme = Replace(arrRws(Cnt + 2), Nme, "", 1, -1, vbBinaryCompare)
Let DispNme = Replace(DispNme, StrtTyp, "", 1, -1, vbBinaryCompare)
Let DispNme = Trim(DispNme)
' fill the array for output
Let arrOut(Cnt, 1) = Nme: arrOut(Cnt, 2) = DispNme: arrOut(Cnt, 3) = StrtTyp
End If

Next Cnt

' Chuck array into a spreadsheet
Let ThisWorkbook.Worksheets("PowerShell").Range("A2").Resize(UBound(arrOut(), 1), 3).Value = arrOut()
ThisWorkbook.Worksheets("PowerShell").Cells.Columns("A:C").EntireColumn.AutoFit

End Sub

Edit Some issues…
I messed up with a few things.
_ the display name could be long and go up to the startuptype in the text file, which messed up the manipulation of a line of data from the text file a bit. For now I fiddled that by adding some spaces before the words used for the startuptype. A better solution will probably wait until I fully understand the PowerShell code line
_ There seems to be some strange effects with something somewhere working too slow, too fast or not giving accurate information about if a text file is present. For now that is fiddled with some Waits , Dirs and a Kill. That will do for now, but that need to be looked at again when I understand better wots going on

The next code version is in the next post
https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=16369&viewfull=1#post16369

DocAElstein

02-09-2022, 11:45 PM

Macro for this post
https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776

'In support of these forum posts
'https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776
'https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
'https://eileenslounge.com/viewtopic.php?f=18&t=37740
'https://eileenslounge.com/viewtopic.php?f=18&t=37712
'https://eileenslounge.com/viewtopic.php?f=18&t=37707

Sub Services2() ' https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776 https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
' kill the text file before I make it, because the code might otherwise use a previous one, as it takes a second or so to overwrite the old or make a new one
Do While Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) <> ""
If Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) <> "" Then Kill PathName:="" & ThisWorkbook.Path & Application.PathSeparator & "test.txt"
Application.Wait (Now + TimeValue("0:00:01"))
Loop
DoEvents: DoEvents
' Application.Wait (Now + TimeValue("0:00:01")) ' I am not sure why I had to do this. It should not be necerssary, without it the text file is empty - maybe Dir says something is there before it is available to have???
' PowerShell
Dim PScmdLet As String, cmdLet As String
'Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\acer\Desktop\test.txt' -Width 1000"
Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath '" & ThisWorkbook.Path & Application.PathSeparator & "test.txt' -Width 2000"
Let PScmdLet = "powershell -command " & cmdLet ' https://www.devhut.net/vba-run-powershell-command/
CreateObject("WScript.Shell").Exec (PScmdLet)
' we need to wait a bit until the text file is made
Do While Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) = ""
Application.Wait (Now + TimeValue("0:00:01"))
Loop
DoEvents: DoEvents ' I chucked this in, but did not really have any reason
Application.Wait (Now + TimeValue("0:00:02")) ' I am not sure why I had to do this. It should not be necerssary, without it the text file is empty - maybe Dir says something is there before it is available to have??? 01 seemed OK - I made it 2
' Get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "test.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundamental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot receives it has to be a string of exactly the right length
Get #FileNum, , TotalFile 'Debug.Print TotalFile
Let TotalFile = Replace(TotalFile, Chr(0), "", 1, -1, vbBinaryCompare) ' There seems to be a lot of Chr(0)s in the string https://i.postimg.cc/t43HCQr9/Rather-a-lot-of-Chr-0-s.jpg
'Let TotalFile = Replace(TotalFile, Chr(255) & Chr(254) & vbCr & vbLf, "", 1, 1, vbBinaryCompare) ' this would tsake the first bit of crap out, (alternatively we can just take out the first line when split later by
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

' make a 1 D array of the text file lines
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)

' make array for output
Dim arrOut() As String: ReDim arrOut(1 To UBound(arrRws()) - 2, 1 To 3) ' we are ignoring the first 3 lines. The UBound of the 1 dimensional array is already 1 less then the lines we need because a 1 dimensional array starts at 0
Dim Cnt As Long
For Cnt = 1 To UBound(arrRws()) - 2
If arrRws(Cnt + 2) = "" Then
' This should occur at the last empty rows, so we could consider jumping out of the loop here
Else
' This is a bit of a temporary bodge as the Display name sometimes pushes up to the startuptype which screws up the string manipulation below
Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Manual", " Manual", 1, 1, vbBinaryCompare): Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Automatic", " Auotomatic", 1, 1, vbBinaryCompare): Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Disabled", " Disabled", 1, 1, vbBinaryCompare)
' time to split the line string
Dim Pos1 As Long: Let Pos1 = InStr(1, arrRws(Cnt + 2), " ", vbBinaryCompare)
Dim Nme As String: Let Nme = Left(arrRws(Cnt + 2), Pos1 - 1)
Dim Pos3 As Long: Let Pos3 = Len(arrRws(Cnt + 2)) - InStrRev(arrRws(Cnt + 2), " ", -1, vbBinaryCompare)
Dim StrtTyp As String: Let StrtTyp = Right(arrRws(Cnt + 2), Pos3)
Dim DispNme As String: Let DispNme = Replace(arrRws(Cnt + 2), Nme, "", 1, 1, vbBinaryCompare)
Let DispNme = Replace(DispNme, StrtTyp, "", 1, 1, vbBinaryCompare)
Let DispNme = Trim(DispNme)
' fill the array for output
Let arrOut(Cnt, 1) = Nme: arrOut(Cnt, 2) = DispNme: arrOut(Cnt, 3) = StrtTyp
End If

Next Cnt

' Chuck array into a spreadsheet
Let ThisWorkbook.Worksheets("PowerShell").Range("A2").Resize(UBound(arrOut(), 1), 3).Value = arrOut()
ThisWorkbook.Worksheets("PowerShell").Cells.Columns("A:C").EntireColumn.AutoFit

End Sub

DocAElstein

02-09-2022, 11:45 PM

test

https://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page52
Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range(”A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occurred" }
finally { $excel .Quit() } # this section will be done if an error occurs

DocAElstein

02-09-2022, 11:45 PM

test

https://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page52
Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range(”A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occurred" }
finally { $excel .Quit() } # this section will be done if an error occurs

DocAElstein

02-09-2022, 11:45 PM

Macro for this post
https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776

'In support of these forum posts
'https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776
'https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
'https://eileenslounge.com/viewtopic.php?f=18&t=37740
'https://eileenslounge.com/viewtopic.php?f=18&t=37712
'https://eileenslounge.com/viewtopic.php?f=18&t=37707

Sub Services2() ' https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12776 https://excelfox.com/forum/showthread.php/2559-Notes-tests-text-files-manipulation-of-text-files-in-Excel-and-with-Excel-VBA?p=15356#post15356
' kill the text file before I make it, because the code might otherwise use a previous one, as it takes a second or so to overwrite the old or make a new one
Do While Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) <> ""
If Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) <> "" Then Kill PathName:="" & ThisWorkbook.Path & Application.PathSeparator & "test.txt"
Application.Wait (Now + TimeValue("0:00:01"))
Loop
DoEvents: DoEvents
' Application.Wait (Now + TimeValue("0:00:01")) ' I am not sure why I had to do this. It should not be necerssary, without it the text file is empty - maybe Dir says something is there before it is available to have???
' PowerShell
Dim PScmdLet As String, cmdLet As String
'Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\acer\Desktop\test.txt' -Width 1000"
Let cmdLet = "Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath '" & ThisWorkbook.Path & Application.PathSeparator & "test.txt' -Width 2000"
Let PScmdLet = "powershell -command " & cmdLet ' https://www.devhut.net/vba-run-powershell-command/
CreateObject("WScript.Shell").Exec (PScmdLet)
' we need to wait a bit until the text file is made
Do While Dir("" & ThisWorkbook.Path & Application.PathSeparator & "test.txt", vbNormal) = ""
Application.Wait (Now + TimeValue("0:00:01"))
Loop
DoEvents: DoEvents ' I chucked this in, but did not really have any reason
Application.Wait (Now + TimeValue("0:00:02")) ' I am not sure why I had to do this. It should not be necerssary, without it the text file is empty - maybe Dir says something is there before it is available to have??? 01 seemed OK - I made it 2
' Get the text file as a long single string
Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function
Dim PathAndFileName As String, TotalFile As String
Let PathAndFileName = ThisWorkbook.Path & Application.PathSeparator & "test.txt" ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic
Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundamental type data input...
Let TotalFile = Space(LOF(FileNum)) '....and wot receives it has to be a string of exactly the right length
Get #FileNum, , TotalFile 'Debug.Print TotalFile
Let TotalFile = Replace(TotalFile, Chr(0), "", 1, -1, vbBinaryCompare) ' There seems to be a lot of Chr(0)s in the string https://i.postimg.cc/t43HCQr9/Rather-a-lot-of-Chr-0-s.jpg
'Let TotalFile = Replace(TotalFile, Chr(255) & Chr(254) & vbCr & vbLf, "", 1, 1, vbBinaryCompare) ' this would tsake the first bit of crap out, (alternatively we can just take out the first line when split later by
Close #FileNum
' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile)

' make a 1 D array of the text file lines
Dim arrRws() As String: Let arrRws() = Split(TotalFile, vbCr & vbLf, -1, vbBinaryCompare)

' make array for output
Dim arrOut() As String: ReDim arrOut(1 To UBound(arrRws()) - 2, 1 To 3) ' we are ignoring the first 3 lines. The UBound of the 1 dimensional array is already 1 less then the lines we need because a 1 dimensional array starts at 0
Dim Cnt As Long
For Cnt = 1 To UBound(arrRws()) - 2
If arrRws(Cnt + 2) = "" Then
' This should occur at the last empty rows, so we could consider jumping out of the loop here
Else
' This is a bit of a temporary bodge as the Display name sometimes pushes up to the startuptype which screws up the string manipulation below
Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Manual", " Manual", 1, 1, vbBinaryCompare): Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Automatic", " Auotomatic", 1, 1, vbBinaryCompare): Let arrRws(Cnt + 2) = Replace(arrRws(Cnt + 2), "Disabled", " Disabled", 1, 1, vbBinaryCompare)
' time to split the line string
Dim Pos1 As Long: Let Pos1 = InStr(1, arrRws(Cnt + 2), " ", vbBinaryCompare)
Dim Nme As String: Let Nme = Left(arrRws(Cnt + 2), Pos1 - 1)
Dim Pos3 As Long: Let Pos3 = Len(arrRws(Cnt + 2)) - InStrRev(arrRws(Cnt + 2), " ", -1, vbBinaryCompare)
Dim StrtTyp As String: Let StrtTyp = Right(arrRws(Cnt + 2), Pos3)
Dim DispNme As String: Let DispNme = Replace(arrRws(Cnt + 2), Nme, "", 1, 1, vbBinaryCompare)
Let DispNme = Replace(DispNme, StrtTyp, "", 1, 1, vbBinaryCompare)
Let DispNme = Trim(DispNme)
' fill the array for output
Let arrOut(Cnt, 1) = Nme: arrOut(Cnt, 2) = DispNme: arrOut(Cnt, 3) = StrtTyp
End If

Next Cnt

' Chuck array into a spreadsheet
Let ThisWorkbook.Worksheets("PowerShell").Range("A2").Resize(UBound(arrOut(), 1), 3).Value = arrOut()
ThisWorkbook.Worksheets("PowerShell").Cells.Columns("A:C").EntireColumn.AutoFit

End Sub

DocAElstein

02-09-2022, 11:45 PM

test

https://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page52
Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range(”A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occurred" }
finally { $excel .Quit() } # this section will be done if an error occurs

DocAElstein

02-09-2022, 11:45 PM

test

https://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)/page52
Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occured" } ; finally {$excel.Quit() } # this section will be done if an error occurs

Remove-Variable * -ErrorAction SilentlyContinue # This is very helpful when developing and debuging skript in the ISE, because the ISE has a habit of maintaining variables values between script executions, so this is needed, or else a removed variable may still be there - when fucking about with variables, this can get you in a very frustrating mess. In technical terms: By default variables are persistant. https://pscustomobject.github.io/powershell/howto/PowerShell-ISE-Clear-Variables/
# https://eileenslounge.com/viewtopic.php?t=33011&sid=726de7ffbd0c03680b62280fd86753e0
# Path I have used for my text file output 'C:\Users\Admin\Desktop\test.txt' here full line Get-Service|Select-Object name,displayname,starttype|Format-Table -AutoSize|Out-File -FilePath 'C:\Users\Admin\Desktop\test.txt' -Width 2000
# and for Excel example file C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls

try # Most of the main coding is in a try section ================================================== ============================
{[object]$excel = New-Object -ComObject Excel.Application # https://www.youtube.com/watch?v=xc8A7Z0JLB0&t=995s
$excel.Visible = $true
[string]$excelPath = "C:\Users\Admin\Desktop\PowerShellAshishRajFeedback .xls"
$excelWB = $excel.workbooks.Open($excelPath)
# Worksheets info
$excelWS=$excelWB.WorkSheets.item("AshishRajCOM")
$excelWS.Activate() # It seems that in PowerShell script an extra () is needed
$excelWS.Cells.Item(1, 1).Value = "name" ; $excelWS.Cells.Item(1, 2).Value = "displayname" ; $excelWS.Cells.Item(1, 3).Value = "starttype"
# write in service
[int]$rowWS = 2
ForEach($Service in Get-Service) { $excelWS.Cells.Item($rowWS, 1).Value = $Service.Name.ToString() ; $excelWS.Cells.Item($rowWS, 2).Value = $Service.DisplayName.ToString() ; $excelWS.Cells.Item($rowWS, 3).Value = $Service.StartType.ToString()
If($Service.Status -eq "Running") { $excelWS.Cells.Item($rowWS, 1).Range(”A1:C1").Font.ColorIndex = 10 }
elseif($Service.Status -eq "Stopped") { $excelWS.Cells.Item($rowWS, 1).Range("A1:C1").Font.ColorIndex = 3 }
$rowWS++ }
$excelWS.Cells.Columns("A:C").EntireColumn.AutoFit() # Tidy up column widths
# $excelWB.SaveAs($excelPath)
$excelWB.Save() # It seems that in PowerShell script an extra () is needed
$excel.Quit() } # ================================================== ================================================== =========
catch { Write-Host "some error occurred" }
finally { $excel .Quit() } # this section will be done if an error occurs

DocAElstein

02-09-2022, 11:45 PM

<div class="gmail_chip gmail_drive_chip">
<div class="gmail_chip gmail_drive_chip">
<p style="margin: 0px;"><span style="font-family: arial,helvetica,sans-serif; font-size: 10pt; color: #000000; text-decoration: none;"><a href="https://www.youtube.com/watch?v=5ckOWXGDL34&lc=UgyqZfLMydnVuNbtqTR4AaABAg. 9ZBy1PrRmM89ZEE6b4w03-">https://www.youtube.com/watch?v=5ckOWXGDL34&lc=UgyqZfLMydnVuNbtqTR4AaABAg. 9ZBy1PrRmM89ZEE6b4w03-</a>       7<br /></span></p>
<p style="margin: 0px;"><span style="font-family: arial,helvetica,sans-serif; font-size: 10pt; color: #000000; text-decoration: none;">https://www.youtube.com/watch?v=5ckOWXGDL34&lc=UgzW4-G9Rh2o5ljabrV4AaABAg</span>       13        </p>
</div>

DocAElstein

02-09-2022, 11:45 PM

In support of this post https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12782
Security tweaks

# Will like XP or Win7 Disable Windows Defender Disable Defender Updates Set UAC to Never Prompt Disable Meltdown Flag Disable Windows Malware Scan
$securitylow.Add_Click({
Write-Host "Lowering UAC level..."
Set-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Po licies\System" -Name "ConsentPromptBehaviorAdmin" -Type DWord -Value 0
Set-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Po licies\System" -Name "PromptOnSecureDesktop" -Type DWord -Value 0
Write-Host "Disabling Windows Defender..."
If (!(Test-Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender")) {
New-Item -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender" -Force | Out-Null
}
Set-ItemProperty -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender" -Name "DisableAntiSpyware" -Type DWord -Value 1
If ([System.Environment]::OSVersion.Version.Build -eq 14393) {
Remove-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Ru n" -Name "WindowsDefender" -ErrorAction SilentlyContinue
} ElseIf ([System.Environment]::OSVersion.Version.Build -ge 15063) {
Remove-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Ru n" -Name "SecurityHealth" -ErrorAction SilentlyContinue
}
Write-Host "Disabling Windows Defender Cloud..."
If (!(Test-Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender\Spynet")) {
New-Item -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender\Spynet" -Force | Out-Null
}
Set-ItemProperty -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender\Spynet" -Name "SpynetReporting" -Type DWord -Value 0
Set-ItemProperty -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender\Spynet" -Name "SubmitSamplesConsent" -Type DWord -Value 2
Write-Host "Disabling Meltdown (CVE-2017-5754) compatibility flag..."
Remove-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Qu alityCompat" -Name "cadca5fe-87d3-4b96-b7fb-a231484277cc" -ErrorAction SilentlyContinue
Write-Host "Disabling Malicious Software Removal Tool offering..."
If (!(Test-Path "HKLM:\SOFTWARE\Policies\Microsoft\MRT")) {
New-Item -Path "HKLM:\SOFTWARE\Policies\Microsoft\MRT" | Out-Null
}
Set-ItemProperty -Path "HKLM:\SOFTWARE\Policies\Microsoft\MRT" -Name "DontOfferThroughWUAU" -Type DWord -Value 1
$wshell.Popup("Operation Completed",0,"Done",0x0)
})

# Enable Windows Malware Scan Enable Meltdown Flag Disable Windows Defender Set UAC to Always Prompt Disable Defender Updates
$securityhigh.Add_Click({
Write-Host "Raising UAC level..."
Set-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Po licies\System" -Name "ConsentPromptBehaviorAdmin" -Type DWord -Value 5
Set-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Po licies\System" -Name "PromptOnSecureDesktop" -Type DWord -Value 1
Write-Host "Disabling SMB 1.0 protocol..."
Set-SmbServerConfiguration -EnableSMB1Protocol $false -Force
Write-Host "Enabling Windows Defender..."
Remove-ItemProperty -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender" -Name "DisableAntiSpyware" -ErrorAction SilentlyContinue
If ([System.Environment]::OSVersion.Version.Build -eq 14393) {
Set-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Ru n" -Name "WindowsDefender" -Type ExpandString -Value "`"%ProgramFiles%\Windows Defender\MSASCuiL.exe`""
} ElseIf ([System.Environment]::OSVersion.Version.Build -ge 15063) {
Set-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Ru n" -Name "SecurityHealth" -Type ExpandString -Value "`"%ProgramFiles%\Windows Defender\MSASCuiL.exe`""
}
Write-Host "Enabling Windows Defender Cloud..."
Remove-ItemProperty -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender\Spynet" -Name "SpynetReporting" -ErrorAction SilentlyContinue
Remove-ItemProperty -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows Defender\Spynet" -Name "SubmitSamplesConsent" -ErrorAction SilentlyContinue
Write-Host "Disabling Windows Script Host..."
Set-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows Script Host\Settings" -Name "Enabled" -Type DWord -Value 0
Write-Host "Enabling Meltdown (CVE-2017-5754) compatibility flag..."
If (!(Test-Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Qu alityCompat")) {
New-Item -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Qu alityCompat" | Out-Null
}
Set-ItemProperty -Path "HKLM:\SOFTWARE\Microsoft\Windows\CurrentVersion\Qu alityCompat" -Name "cadca5fe-87d3-4b96-b7fb-a231484277cc" -Type DWord -Value 0
Write-Host "Enabling Malicious Software Removal Tool offering..."
Remove-ItemProperty -Path "HKLM:\SOFTWARE\Policies\Microsoft\MRT" -Name "DontOfferThroughWUAU" -ErrorAction SilentlyContinue
$wshell.Popup("Operation Completed",0,"Done",0x0)
})

DocAElstein

02-09-2022, 11:45 PM

In support of this post
https://excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page51#post12783
The ps1 file, and also below the $WindowsSearch.Add_Click(
Share ‘ChrisSearchTweaks18-19July.ps1 https://app.box.com/s/cbs7go8i2tdxw4wguthgxcviecaxjn6b
iex ((New-Object System.Net.WebClient).DownloadString(' https://raw.githubusercontent.com/ChrisTitusTech/win10script/71609526b132f5cd7e3b9167779af60051a80912/win10debloat.ps1'))

$windowssearch.Add_Click({
Write-Host "Disabling Bing Search in Start Menu..."
Set-ItemProperty -Path "HKCU:\Software\Microsoft\Windows\CurrentVersion\Se arch" -Name "BingSearchEnabled" -Type DWord -Value 0
<#
Write-Host "Disabling Cortana"
Set-ItemProperty -Path "HKCU:\SOFTWARE\Microsoft\Windows\CurrentVersion\Se arch" -Name "CortanaConsent" -Type DWord -Value 0
If (!(Test-Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows\Windows Search")) {
New-Item -Path "HKLM:\SOFTWARE\Policies\Microsoft\Windows\Windows Search" -Force | Out-Null
}
#>
Write-Host "Hiding Search Box / Button..."
Set-ItemProperty -Path "HKCU:\Software\Microsoft\Windows\CurrentVersion\Se arch" -Name "SearchboxTaskbarMode" -Type DWord -Value 0

Write-Host "Removing Start Menu Tiles"

Set-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -Value '<LayoutModificationTemplate xmlns:defaultlayout="http://schemas.microsoft.com/Start/2014/FullDefaultLayout" xmlns:start="http://schemas.microsoft.com/Start/2014/StartLayout" Version="1" xmlns="http://schemas.microsoft.com/Start/2014/LayoutModification">'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <LayoutOptions StartTileGroupCellWidth="6" />'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <DefaultLayoutOverride>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <StartLayoutCollection>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <defaultlayout:StartLayout GroupCellWidth="6" />'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </StartLayoutCollection>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </DefaultLayoutOverride>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <CustomTaskbarLayoutCollection>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <defaultlayout:TaskbarLayout>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <taskbar:TaskbarPinList>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <taskbar:UWA AppUserModelID="Microsoft.MicrosoftEdge_8wekyb3d8bbwe!MicrosoftEdg e" />'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' <taskbar:DesktopApp DesktopApplicationLinkPath="%APPDATA%\Microsoft\Windows\Start Menu\Programs\System Tools\File Explorer.lnk" />'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </taskbar:TaskbarPinList>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </defaultlayout:TaskbarLayout>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value ' </CustomTaskbarLayoutCollection>'
Add-Content -Path 'C:\Users\Default\AppData\Local\Microsoft\Windows\ Shell\DefaultLayouts.xml' -value '</LayoutModificationTemplate>'

$START_MENU_LAYOUT = @"
<LayoutModificationTemplate xmlns:defaultlayout="http://schemas.microsoft.com/Start/2014/FullDefaultLayout" xmlns:start="http://schemas.microsoft.com/Start/2014/StartLayout" Version="1" xmlns:taskbar="http://schemas.microsoft.com/Start/2014/TaskbarLayout" xmlns="http://schemas.microsoft.com/Start/2014/LayoutModification">
<LayoutOptions StartTileGroupCellWidth="6" />
<DefaultLayoutOverride>
<StartLayoutCollection>
<defaultlayout:StartLayout GroupCellWidth="6" />
</StartLayoutCollection>
</DefaultLayoutOverride>
</LayoutModificationTemplate>
"@

$layoutFile="C:\Windows\StartMenuLayout.xml"

#Delete layout file if it already exists
If(Test-Path $layoutFile)
{
Remove-Item $layoutFile
}

#Creates the blank layout file
$START_MENU_LAYOUT | Out-File $layoutFile -Encoding ASCII

$regAliases = @("HKLM", "HKCU")

#Assign the start layout and force it to apply with "LockedStartLayout" at both the machine and user level
foreach ($regAlias in $regAliases){
$basePath = $regAlias + ":\SOFTWARE\Policies\Microsoft\Windows"
$keyPath = $basePath + "\Explorer"
IF(!(Test-Path -Path $keyPath)) {
New-Item -Path $basePath -Name "Explorer"
}
Set-ItemProperty -Path $keyPath -Name "LockedStartLayout" -Value 1
Set-ItemProperty -Path $keyPath -Name "StartLayoutFile" -Value $layoutFile
}

#Restart Explorer, open the start menu (necessary to load the new layout), and give it a few seconds to process
Stop-Process -name explorer
Start-Sleep -s 5
$wshell = New-Object -ComObject wscript.shell; $wshell.SendKeys('^{ESCAPE}')
Start-Sleep -s 5

#Enable the ability to pin items again by disabling "LockedStartLayout"
foreach ($regAlias in $regAliases){
$basePath = $regAlias + ":\SOFTWARE\Policies\Microsoft\Windows"
$keyPath = $basePath + "\Explorer"
Set-ItemProperty -Path $keyPath -Name "LockedStartLayout" -Value 0

Write-Host "Search and Start Menu Tweaks Complete"
} # This was missing 12 July 2021
})

DocAElstein

02-09-2022, 11:45 PM

jADHKJASHDKJahdjkAHD

DocAElstein

02-09-2022, 11:45 PM

<div class="gmail_chip gmail_drive_chip"> </div>
<div class="gmail_chip gmail_drive_chip"><a href="https://drive.google.com/file/d/1UFQySI4QjTTV0O5xnLnLfx5iJh_qDzct/view?usp=drive_web" target="_blank" rel="noopener" aria-label="5.50 8.18 Clean Up Windows 10 _ 3 Steps For A Faster Computer-mWHiP9K8fQ0_16 10 2019.wmv"><img src="https://ssl.gstatic.com/docs/doclist/images/icon_10_generic_list.png" alt="" data-upload="true" /> <span dir="ltr">5.50 8.18 Clean Up Windows 10 _ 3 Steps For A ...</span></a><img src="res/6c654bc40d912309e7cc090257628b4f/texteditor/void.gif" alt="" data-upload="true" /></div>
<div class="gmail_chip gmail_drive_chip"><a href="https://drive.google.com/file/d/11mjTzHbcdY1EwVaV0-AIAmYgC2DCsp7X/view?usp=drive_web" target="_blank" rel="noopener" aria-label="7.56 8 (Ransome) How to Make Windows 10 Secure-pGcerfVqYyU_31 01 2020.wmv"><img src="https://ssl.gstatic.com/docs/doclist/images/icon_10_generic_list.png" alt="" data-upload="true" /> <span dir="ltr">7.56 8 (Ransome) How to Make Windows 10 Secur...</span></a><img src="res/6c654bc40d912309e7cc090257628b4f/texteditor/void.gif" alt="" data-upload="true" /></div>
<div class="gmail_chip gmail_drive_chip"><a href="https://drive.google.com/file/d/1b_akgpleMvL4lD4qXYffzUEXh8WhUyZ7/view?usp=drive_web" target="_blank" rel="noopener" aria-label="8.45 Speed Up Windows 10 in 2020-8E6OT_QcHaU_20 06 2020.wmv"><img src="https://ssl.gstatic.com/docs/doclist/images/icon_10_generic_list.png" alt="" data-upload="true" /> <span dir="ltr">8.45 Speed Up Windows 10 in 2020-8E6OT_QcHaU_20...</span></a><img src="res/6c654bc40d912309e7cc090257628b4f/texteditor/void.gif" alt="" data-upload="true" /></div>
<div class="gmail_chip gmail_drive_chip"> </div>
<div class="gmail_chip gmail_drive_chip"><a href="https://drive.google.com/file/d/1O63RdRCQS2OvWa50F56m6KyryVsBImIK/view?usp=drive_web" target="_blank" rel="noopener" aria-label="8.94 Creating New Windows 10 Debloat Scripts fo..."><img src="https://drive-thirdparty.googleusercontent.com/16/type/video/x-ms-wmv" alt="" data-upload="true" /> <span dir="ltr">8.94 Creating New Windows 10 Debloat Scripts fo...</span></a></div>
<div class="gmail_chip gmail_drive_chip"> </div>