Code:
Sub TextFileToTabular() ' https://eileenslounge.com/viewtopic.php?p=277881#p277881
Rem 1 Worksheets info, (any worksheet will do to test paste out to)
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets.Item("TextToTabular")
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)
'2a)(ii) Some simple tidying up of complete string
Let TotalFile = Replace(TotalFile, ": http", "http", 1, -1, vbBinaryCompare) ' there are some strange : http which in combination with the next line will/ would introduce an error
Let TotalFile = Replace(TotalFile, "http", " http", 1, -1, vbBinaryCompare) ' this ensures at least two spaces before any link
' 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) We are looping all row data: Some is single element(column) entries , some is multi element(column) data. We want to try to fill up a 6 element(column) array
Dim arrRw() As String: ReDim arrRw(1 To 6) ' we know our columns are 6 entries
' 2d) we make an array for all the final rows
Dim arrHarray() As Variant: Dim HarryCnt As Long: Let HarryCnt = 1
Dim Cnt As Long
Do While Not Cnt = RwCnt - 1 ' We are looping all row data: Some is single element(column) entries , some is multi element(column) data
'For Cnt = 1 To RwCnt
' 2c) _(A)
Do While (arrRw(1) = "" Or arrRw(2) = "" Or arrRw(3) = "" Or arrRw(4) = "" Or arrRw(5) = "" Or arrRw(6) = "") ' we try to fill all 6 element(column) data in the array, but we try to deal with some missing
If arrRws(Cnt) <> "" Then
Let Cnt = Cnt + 1
' _(B)
If InStr(1, Trim(arrRws(Cnt - 1)), " ", vbBinaryCompare) = 0 Then ' this is the case of a rouge line
' _(C)
If InStr(1, Trim(arrRws(Cnt - 1)), "@", vbBinaryCompare) <> 0 Or InStr(1, Trim(arrRws(Cnt - 1)), "https://www.instagram.com", vbBinaryCompare) <> 0 Or InStr(1, Trim(arrRws(Cnt - 1)), "https://www.facebook.com", vbBinaryCompare) <> 0 Or InStr(1, Trim(arrRws(Cnt - 1)), "http://reddit.com", vbBinaryCompare) <> 0 Then
If arrRw(5) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(5) = Trim(arrRws(Cnt - 1))
' _(D)
ElseIf InStr(1, Trim(arrRws(Cnt - 1)), "https://open.spotify.com/", vbBinaryCompare) <> 0 Then
If arrRw(6) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(6) = Trim(arrRws(Cnt - 1))
ElseIf IsNumeric(Trim(arrRws(Cnt - 1))) Then
If arrRw(4) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(4) = Trim(arrRws(Cnt - 1))
ElseIf InStr(1, Trim(arrRws(Cnt - 1)), ",", vbBinaryCompare) <> 0 Then
Dim ExtrGenitals As String
If ExtrGenitals <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let ExtrGenitals = Trim(arrRws(Cnt - 1))
Else
End If
Else ' we have a line with multiple data, assuming that such data is seperated by at least 2 spaces " "
Dim DataSRw As String: Let DataSRw = arrRws(Cnt - 1)
Let DataSRw = LTrim(DataSRw) & " " ' take off any preceding spaces and add a few spaces so that next Loop works for the last element
Dim posTwoSpcs As Long
Do While DataSRw <> "" ' looping to get all data from a dataS row ----
Dim ClmCnt As Long: Let ClmCnt = ClmCnt + 1
Let posTwoSpcs = InStr(1, DataSRw, " ", vbBinaryCompare)
If ClmCnt > 3 Then ' after the third entry things may be not incorrect order
Dim UnOrdedIndataSRw As String
Let UnOrdedIndataSRw = Left(DataSRw, (posTwoSpcs - 1))
If InStr(1, UnOrdedIndataSRw, "@", vbBinaryCompare) <> 0 Or InStr(1, UnOrdedIndataSRw, "https://www.instagram.com", vbBinaryCompare) <> 0 Or InStr(1, UnOrdedIndataSRw, "https://www.facebook.com", vbBinaryCompare) <> 0 Or InStr(1, UnOrdedIndataSRw, "http://reddit.com", vbBinaryCompare) <> 0 Then
If arrRw(5) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(5) = UnOrdedIndataSRw
ElseIf InStr(1, UnOrdedIndataSRw, "https://open.spotify.com/", vbBinaryCompare) <> 0 Then
If arrRw(6) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(6) = UnOrdedIndataSRw
Else
If arrRw(ClmCnt) <> "" Then Let Cnt = Cnt - 1: GoTo Missing
Let arrRw(ClmCnt) = Left(DataSRw, (posTwoSpcs - 1))
End If
Else
Let arrRw(ClmCnt) = Left(DataSRw, (posTwoSpcs - 1))
If ClmCnt = 3 And InStr(1, arrRw(3), " ", vbBinaryCompare) <> 0 And (InStr(1, arrRw(3), "@", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "https://www.instagram.com", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "https://www.facebook.com", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "http://reddit.com", vbBinaryCompare) <> 0) Then ' We may have a problem that after the Genres data has a link added with just one space that should be the fifth column (Best Way To Contact)
Dim SptGenitral() As String: Let SptGenitral() = Split(arrRw(3), " ", -1, vbBinaryCompare)
Let arrRw(5) = SptGenitral(UBound(SptGenitral))
Let arrRw(3) = Replace(arrRw(3), " " & arrRw(5), "", 1, -1, vbBinaryCompare)
Let posTwoSpcs = InStr(1, DataSRw, " ", vbBinaryCompare)
' _(B)(i) The macro will deal with some cases of Curator and Genres only being separated by one space This next bit may sort out if the Curator is in two words and is only seperated from the Playlist Name by 1 space
ElseIf InStr(1, arrRw(3), "@", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "https://www.instagram.com", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "https://www.facebook.com", vbBinaryCompare) <> 0 Or InStr(1, arrRw(3), "http://reddit.com", vbBinaryCompare) <> 0 Then
Let arrRw(5) = arrRw(3)
Let arrRw(3) = arrRw(2)
Dim Spt1a() As String: Let Spt1a() = Split(arrRw(1), " ", -1, vbBinaryCompare)
Let arrRw(2) = Spt1a(UBound(Spt1a()) - 1) & " " & Spt1a(UBound(Spt1a()))
ElseIf InStr(1, arrRw(3), "https://open.spotify.com/", vbBinaryCompare) <> 0 Then
Let arrRw(6) = arrRw(3)
Let arrRw(3) = arrRw(2)
Let arrRw(1) = Replace(arrRw(1), arrRw(2), "", 1, 1, vbBinaryCompare)
Dim Spt1b() As String: Let Spt1b() = Split(arrRw(1), " ", -1, vbBinaryCompare)
Let arrRw(2) = Spt1b(UBound(Spt1b()) - 1) & " " & Spt1b(UBound(Spt1b()))
Let arrRw(1) = Replace(arrRw(1), arrRw(2), "", 1, 1, vbBinaryCompare)
End If
End If
Let DataSRw = Mid(DataSRw, posTwoSpcs)
Let DataSRw = LTrim(DataSRw)
Loop ' looping to get all data from a dataS row ----
End If
Else ' case empty row
Let Cnt = Cnt + 1 ' increase to next data row from the text file
If Cnt = RwCnt Then GoTo Bed
End If
Loop ' While (arrRw(1) = "" Or arrRw(2) = "" Or arrRw(3) = "" Or arrRw(4) = "" Or arrRw(5) = "" Or arrRw(6) = "")
Missing: ' _(A)(i) we come here if we tried to fill an already filled element, which indicates we had something missing
Let arrRw(3) = arrRw(3) & ExtrGenitals ' modify Genres string to include any appearing in a rogue line
' 2d)(ii) At this point its time to put the current completed row data into the jagged array to use late in Index
Rem 3 An array is built up by using that interesting "Index on a unjagged jagged 1Ds arrays technique" that we first noticed here: https://eileenslounge.com/viewtopic.php?p=266691#p266691 https://eileenslounge.com/viewtopic.php?p=266727#p266727 https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
ReDim Preserve arrHarray(1 To HarryCnt)
Let arrHarray(HarryCnt) = arrRw()
Let HarryCnt = HarryCnt + 1
ReDim arrRw(1 To 6) ' this resets (empties) the row array
Let ClmCnt = 0
Let ExtrGenitals = ""
Loop ' While Not Cnt = RwCnt-1
Bed: ' This section will deal with a problem of the last row in harry being missed if it is missing some data
ReDim Preserve arrHarray(1 To HarryCnt)
Let arrHarray(HarryCnt) = arrRw()
Rem 4 Finally the array is pasted to worksheet ' use of that interesting "Index on a unjagged jagged 1Ds arrays technique" that we first noticed here: https://eileenslounge.com/viewtopic.php?p=266691#p266691 https://eileenslounge.com/viewtopic.php?p=266727#p266727 https://www.ozgrid.com/forum/index.php?thread/1227920-slicing-a-2d-array/&postID=1239241#post1239241
Dim RngOut As Range: Set RngOut = Worksheets("TextToTabular").Range("A1:F" & UBound(arrHarray()) & "")
Let RngOut.Value = Application.Index(arrHarray(), Evaluate("=row(1:" & UBound(arrHarray()) & ")"), Array(1, 2, 3, 4, 5, 6))
Worksheets("TextToTabular").Columns("A:F").AutoFit
'' 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