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

**DocAElstein** · 05-19-2020, 03:26 AM

Macro for last post

Code:

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

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

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

**DocAElstein** · 05-19-2020, 03:08 PM

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

Code:


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

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

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

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

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

**DocAElstein** · 05-20-2020, 12:12 AM

Test ranges used to answer this post:
https://excelfox.com/forum/showthrea...ll=1#post13401

Before:

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G	H	J	L	M	N	O	P	Q
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ASHOKLEY	EQ	65	65.35	60.55	63.3	63.3	1	1	60	1.055	1.055	54	56.97
3	NSE	BANKBARODA	EQ	62.1	62.95	56.15	56.65	56.65	1	6	60	0.944167	5.665	54	50.985
4	NSE	BEL	EQ	66.15	66.75	62.4	65.65	65.65	1	6	60	1.094167	6.565	54	59.085
5	NSE	EQUITAS	EQ	82	82.05	71	73.05	73.05	1	1	60	1.2175	1.2175	54	65.745
6	NSE	FEDERALBNK	EQ	68	68.45	62.45	63.1	63.1	1	6	60	1.051667	6.31	54	56.79
7	NSE	GAIL	EQ	85	88.8	79.1	79.95	79.95	1	6	60	1.3325	7.995	54	71.955
8	NSE	IDFCFIRSTB	EQ	32.1	32.35	27.2	27.55	27.55		1	60	0.459167	0.459167	54	24.795
9	NSE	IOC	EQ	93	93.65	87.25	87.9	87.9		1	60	1.465	1.465	54	79.11
10	NSE	L&TFH	EQ	90	91.55	80.5	81.65	81.65		6	51	1.60098	9.605882	54	86.45294
11

Worksheet: Sheet1 (2)

_____ Workbook: 2.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Stock Name	data	data	data	data	data	data	data	data	data	data	data	data	data	data
2	ACC	100	108	120	128	134	151	6534	30	90	97	103
3	ADANIENT	101	109	121	127	135	122	782	40	92	98
4	ADANIPORTS	102	110	122	16	137	177	10	50	93	99	104
5	ASHOKLEY	1	2	3	4	5	16	137	177
6	ANJALIPHARMA	10	50	93	99	5	102	110	122	9	10	11
7	SUNTECK	11	12	13	14	15	16	17	18	19	20	21	22	23
8

Worksheet: Sheet1 (5)

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	O	P	Q	R	S
6	6.31	54	56.79
7	7.995	54	71.955	Total Fund Amount	8387.320769
8	0.459167	54	24.795	Current Fund Amount	9000
9	1.465	54	79.11	Fund Allocated	8000
10	9.605882	54	86.45294	Profit Amount	1000
11		Sum is	551.8879

Worksheet: Sheet1 (2)

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	Q
2	56.97
3	50.985
4	59.085
5	65.745
6	56.79
7	71.955
8	24.795
9	79.11
10	86.45294
11	=SUM(Q2:Q10)

Worksheet: Sheet1 (2)

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

**DocAElstein** · 05-20-2020, 12:24 AM

Macro for last post, and to answer this post:
https://excelfox.com/forum/showthrea...ll=1#post13401

Code:

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

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

**DocAElstein** · 05-20-2020, 02:23 AM

Just testing
ignore all this

C:\Users

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

**DocAElstein** · 05-24-2020, 12:58 PM

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

**DocAElstein** · 05-24-2020, 11:14 PM

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

**DocAElstein** · 05-25-2020, 02:44 PM

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

**DocAElstein** · 05-25-2020, 03:05 PM

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