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
Bookmarks