continued from last post
Code:Sub ConventionalTextImport() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35100&p=274367#p274367 http://www.eileenslounge.com/viewtopic.php?f=30&t=34629&p=274370#p274370 http://www.eileenslounge.com/viewtopic.php?p=274721#p274721 Rem 1 Worksheets info, (any worksheet will do to paste out to) Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item("ConventionalTextImport") 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 & Application.PathSeparator & "tt.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: Debug.Print TotalFile Close #FileNum ' Let TotalFile = Replace(TotalFile, """", "", 1, -1, vbBinaryCompare): Debug.Print TotalFile ' removed enclosing quotes in rabsofty's text file ' Call WtchaGot_Unic_NotMuchIfYaChoppedItOff(TotalFile) ' 2b) Split into wholes line _ splitting the text file into rows by splitting by Line Seperator 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... '' 2c) split first line to determine the Field(column) number 'Dim arrClms() As String: Let arrClms() = Split(arrRws(0), ",", -1, vbBinaryCompare) 'Dim ClmCnt As Long: Let ClmCnt = UBound(arrClms()) + 1 Dim ClmCnt As Long: Let ClmCnt = 1 ' 2d) 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 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) ' At each of these "inner" loops we fill either a the array with an element Let arrOut(Cnt, 1) = arrRws(Cnt - 1) ' Next Clm Next Cnt Rem 4 Finally the array is pasted to worksheet Dim RngOut As Range: Set RngOut = Ws1.Range("A1").Resize(RwCnt, ClmCnt) RngOut.ClearContents Let RngOut.Value = arrOut() ' 4b Option to remove the little ... when i click on any cell that has output there is an option numbers stored as text, convert to numbers,help on this error,ignore error,edit in formula bar,error checking options(these are the options coming)… Let RngOut.Value = Evaluate("=IF(" & RngOut.Address & "="""","""",IF(ISNUMBER(1*" & RngOut.Address & "),1*" & RngOut.Address & "," & RngOut.Address & "))") ' http://www.eileenslounge.com/viewtopic.php?p=272704#p272704 End Sub




Reply With Quote
Bookmarks