Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)

Macro for this Thread post
https://excelfox.com/forum/showthrea...ll=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

Code:

---

Sub CalculationByPercentageAndConditionallyPutingTheData() '  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
Attachment 2954

---

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

macro for this post http://www.eileenslounge.com/viewtop...268809#p268809

Code:

---

'                                                                              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

In support of this Thread https://excelfox.com/forum/showthrea...3427#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
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ACC	EQ	1172	1240	1161.6	1227.1	1227.1	22
3	NSE	ADANIENT	EQ	138	141.2	136.6	138.1	140	25
4	NSE	ADANIPORTS	EQ	315	315	306.55	310.6	312	15083
5	NSE	ADANIPOWER	EQ	33.5	34.5	32.85	33	33.2	17388
6	NSE	AMARAJABAT	EQ	600	613.5	586.9	592.55	592.55	100
7	NSE	ASIANPAINT	EQ	1568.8	1625	1555.4	1617.9	1617.9	236

Worksheet: 1-Sheet1 24Mai

Text File:

Code:

---

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
2	Column 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.
3	Column 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.
4	Column 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
5	Column 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
6	Column H is < Column D Column D - 1% is not < Column I so no match to be done , nothing more to be done
7	Column 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

Code:

---

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

---

Macro solution for this post: https://excelfox.com/forum/showthrea...3427#post13427

Code:

---

'  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

test asdsdklj




aslkhSLHDSlhdslhfslkhasklh




ASFJALSKJFASLKJFASLKJFASLKFJALKSJFSLKAJ

lSHFLSHFHSLHF

assfhshffhsfskfh

In support of answer for this post.
https://excelfox.com/forum/showthrea...3470#post13470

Text file supplied Sample2.csv ( Avinash : https://excelfox.com/forum/showthrea...ll=1#post13470
sample2 ef 5 June.csv : https://app.box.com/s/0j4118cwzzofe76ytb5rqkvz3qj0vseu
sample2.csv : https://app.box.com/s/0ej2h41g9fvm94cflf2j60a8o6p3334t )

Code:

---

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/showthrea...ll=1#post13440 , for example with text editor
OpenSample2_csvManually with Excel.JPG : https://imgur.com/e7CxxpV)
Attachment 2963

_____ Workbook: sample2.csv ( Using Excel 2007 32 bit )

Row\Col	A	B
1	NSE,101010,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
2	NSE,22,6,<,12783,A,,,,,GTT,,,,,,,,,,,,,
3	NSE,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:

Code:

---

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/showthrea...ll=1#post13476

Code:

---

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
1	NSE	101010	6	<	12783	A					GTT
2	NSE	22	6	<	12783	A					GTT
3	NSE	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

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

Sample2After.csv

Code:

---

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
1	NSE,101010,6,<,12783,A,,,,,GTT
2	NSE,22,6,<,12783,A,,,,,GTT
3	NSE,17388,6,<,12783,A,,,,,GTT
4	,100,,,,,,,,,,
5	,25,,,,,,,,,,
6

Worksheet: Sample2After





In Excel VBA

Code:

---

_ 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
1	NSE	101010	6	<	12783	A					GTT
2	NSE	22	6	<	12783	A					GTT
3	NSE	17388	6	<	12783	A					GTT
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

---

---

Code:

---

Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFileToRwCnt)


---

Code:

---

"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

---

Macro for this post:
https://excelfox.com/forum/showthrea...ll=1#post13470

Code:

---

'    https://excelfox.com/forum/showthread.php/2505-copy-paste-the-data-if-condition-matches?p=13470#post13470
Sub VBAAppendDataToTextFileLineBasedOnTheTextFileAndExcelFileConditions()
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(TotalFileToRwCnt)

'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

Macro for this post
https://excelfox.com/forum/showthrea...-condition-met

Code:

---

Sub VBAAppendDataToExcelFileRowBasedOnTwoExcelFileConditions2()  '          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

Macro to answer this Thread
https://excelfox.com/forum/showthrea...ete-entire-row

Code:

---

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

Macro for this post:
https://excelfox.com/forum/showthrea...ata-if-matches

Code:

---

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

In support of these posts
https://excelfox.com/forum/showthrea...ll=1#post13617
https://excelfox.com/forum/showthrea...ll=1#post13470

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

Code:

---

"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

---

Code:

---

"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,,,,,,,,,

Code:

---

"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

---

Code:

---

"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/showthrea...ll=1#post13617
sampLE2AFTER.csv : https://drive.google.com/file/d/1Tyf...gWwzZ3s43YxzwA
sample2BEFORE : https://drive.google.com/file/d/1X2M...vIqNATRC34o5hD


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

Macro for this post:
https://excelfox.com/forum/showthrea...ll=1#post13617

Code:

---

Sub VBAAppendDataToTextFileLineBasedOnTheTextFileAndExcelFileConditions2()  '  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(TotalFileToRwCnt)

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

Question 1

Solution for this question, ( 2020-05-28 22:13:09 Rajesh Kumar )
https://excel.tips.net/T002145_Dynam...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/showthrea...ll=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_Dynam...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/thread...value.1135674/

Macros for this post ( Question 1 )
https://excelfox.com/forum/showthrea...ll=1#post13443

Code:

---

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_Dynam...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/thread...value.1135674/

Macro for these posts ( Question 2 )
https://excelfox.com/forum/showthrea...ll=1#post13442
https://excelfox.com/forum/showthrea...ll=1#post13448

Code:

---

'  _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\AllenWyatt\[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

Macros for this post
https://excelfox.com/forum/showthrea...ll=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
4		ANUJ
5		RITA
6		MUKESH
7		RAM
8		RAHIN
9		Anshu
10

Worksheet: Master Sheet

Code:

---

'  _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

Code:

---

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\AllenWyatt\[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

Code:

---

'
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

Code:

---

Option Explicit
Dim LRng As Range

---

---

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

kkfhhfsfhsah

In suppot of this forum post
https://www.excelforum.com/excel-pro...ml#post5340103

Code:

---

'    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

---

In suppot of this forum post
https://excelfox.com/forum/showthrea...sx-to-txt-file
https://www.excelfox.com/forum/showt...ge30#post13348

Code:

---

' 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
'

---

lKSHFLhlhfl

lKSHFLhlhfl

lKSHFLhlhfl

test ...


test

skjfSKJHFkjhfKJSHFSKJHFskjhf

Different File Types used for simple values
See here ( This post https://excelfox.com/forum/showthrea...ge30#post13349 )
for typical comparisons of text Files, Excel files, and data files
Text File: https://excelfox.com/forum/showthrea...ll=1#post13693
Excel File: https://excelfox.com/forum/showthrea...ll=1#post13694
Data File: https://excelfox.com/forum/showthrea...ll=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/showthrea...ll=1#post13717

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

Code:

---

' 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\Col	A	B	C	D	E	F	G	H	I	J	K	L
1	NSE	101010	6	<	12783	A					GTT
2	NSE	22	6	<	12783	A					GTT
3	NSE	17388	6	<	12783	A					GTT
4

Worksheet: Sheet1

---

lKSHFLhlhfl

Just testing links to Threads


( This post is https://excelfox.com/forum/showthrea...ge30#post13349 )

---

Quote:

---

Originally Posted by DocAElstein

Some notes related to these posts

https://excelfox.com/forum/showthrea...rt-Csv-To-Xlsx https://excelfox.com/forum/showthrea...ll=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtop...267706#p267706
http://www.eileenslounge.com/viewtop...269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fe...2/#post-264364


Later

---

See here ( This post https://excelfox.com/forum/showthrea...ge30#post13349 )
for typical comparisons of text Files, Excel files, and data files
Text File: https://excelfox.com/forum/showthrea...ll=1#post13693
Excel File: https://excelfox.com/forum/showthrea...ll=1#post13694
Data File: https://excelfox.com/forum/showthrea...ll=1#post13695

In support of this thread answer
https://excelfox.com/forum/showthrea...rt-Csv-To-Xlsx

Code:

---

' 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

---

In support of the answer to these forum Thread posts
https://www.excelforum.com/excel-pro...een-files.html
https://excelfox.com/forum/showthrea...ll=1#post14130

Code:

---

'  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

---

post to get the URL - for later use

Solution1 fo this Thread
http://www.eileenslounge.com/viewtop...270792#p270792

Code:

---

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

---

post to get the URL - for later use

Solution for this post:
https://eileenslounge.com/viewtopic....271047#p271047
https://eileenslounge.com/viewtopic....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....270792#p270792

Code:

---

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

---

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

Code:

---

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

---

Macro for solution 4 for this Thread here
https://eileenslounge.com/viewtopic.php?f=30&t=34878
Post
https://eileenslounge.com/viewtopic....5c9974#p271181

Code:

---

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



---

Notes in support of this Thread
https://excelfox.com/forum/showthrea...ther-workbooks

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

Row\Col	A	B	C	D	E	F	G	H	I
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ADANIENT	EQ	151.85	165.45	151.4	151.85	152.35	25
3	NSE	AMARAJABAT	EQ	662.5	665.9	642.55	662.5	643.5	100

Worksheet: 1-Sheet1 6July

_____ Workbook: ap.xls ( 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	Y	Z
1	UserId	AccountId	EntityName	Exchg-Seg	Symbol	Instrument Name	Option Type	NetBuyValue	NetSellValue	NetValue	NetBuyQty	NetSellQty	NetQty	BEP	SellAvgPrice	BuyAvgPrice	LastTradedPrice	MarkToMarket	Realized MarkToMarket	Unrealized MarkToMarket	EL MarkToMarket	Trading Symbol	Client Context	Series/Expiry	Strike Price
2		WC5758		NSE	AMBUJACEM	EQ		10781.10	10878.30	97.20	54	54			201.45	199.65	201	97.2	97.2		97.2	AMBUJACEM-EQ		EQ
3		WC5758		NSE	ADANIENT	EQ		420.60	430.50	9.90	2	2			215.25	210.30	210.35	9.9	9.9		9.9	ADANIENT-EQ		EQ		25
4		WC5758		NSE	SIEMENS	EQ		2609.30	2642.50	33.20	2	2			1321.25	1304.65	1322.7	33.2	33.2		33.2	SIEMENS-EQ		EQ
5		WC5758		NSE	RBLBANK	EQ		502.10	530.30	28.20	2	2			265.15	251.05	249.75	28.2	28.2		28.2	RBLBANK-EQ		EQ
6		WC5758		NSE	NATIONALUM	EQ		1768.50	1782.00	13.50	54	54			33.00	32.75	32.75	13.5	13.5		13.5	NATIONALUM-EQ		EQ
7		WC5758		NSE	MARICO	EQ		1688.40	1713.00	24.60	6	6			285.50	281.40	281.9	24.6	24.6		24.6	MARICO-EQ		EQ
8		WC5758		NSE	AMARAJABAT	EQ		2429.10	2405.70	-23.40		18			133.65	134.95	135	-23.4	-23.4		-23.4	APOLLOTYRE-EQ		EQ		100
9		WC5758		NSE	L&TFH	EQ		1765.80	1794.60	28.80	18	18			99.70	98.10	98.25	28.8	28.8		28.8	L&TFH-EQ		EQ
10		WC5758		NSE	ITC	EQ		360.90	366.10	5.20	2	2			183.05	180.45	180.85	5.2	5.2		5.2	ITC-EQ		EQ
11		WC5758		NSE	INFRATEL	EQ		10988.00	11180.70	192.70	54	54			207.05	203.48	203.8	192.7	192.7		192.7	INFRATEL-EQ		EQ
12		WC5758		NSE	DLF	EQ		93069.00	94283.00	1214.00	486	486			194.00	191.50	190.3	1214	1214		1214	DLF-EQ		EQ

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\Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	NSE	EQ		NA	NA	NA	0		0	BUY	MARKET	NA	CLI	MIS	DAY	WC5758	NA			3	NA
2	NSE	EQ		NA	NA	NA	0		0	SELL	SL-M		CLI	MIS	DAY	WC5758	NA			NA	NA
3	NSE	EQ		NA	NA	NA	0		0	SELL	MARKET	NA	CLI	MIS	DAY	WC5758	NA			3	NA
4	NSE	EQ		NA	NA	NA	0		0	BUY	SL-M		CLI	MIS	DAY	WC5758	NA			NA	NA

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
1	NSE	EQ		NA	NA	NA	0		0	BUY	MARKET	NA	CLI	MIS	DAY	WC5758	NA			3	NA

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

Macro solution for this post:
https://excelfox.com/forum/showthrea...ther-workbooks

Code:

---

'  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


---

Macro for this post
https://eileenslounge.com/viewtopic....271237#p271237
https://eileenslounge.com/viewtopic....271255#p271255

Code:

---

'    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

---