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