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
Reply With Quote
Bookmarks