I am looking for a way to read from a feed webpage which its structure is something like
A,B,C;E,F,G;....
I want to read this data and put A B and C in the first row and put E F and G in row 2, and etc.
I was looking for a function in VBA, but most of them are for only one determiner.
I also was thinking of using string functions of VBA, which that would be the last resort! Since I must read a long string and then use a cursor (which I don't know if it is like c or not!) that probably leads to unstable performance because first I don't know the volume of data, and second I want to use it in a loop.
Could you please help me with the best solution?
feed = "A,B,C;E,F,G;...."
CSV = Replace( feed, ";", vbNewLine )
TSV = Replace( CSV , ",", vbTab )
Set do = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' this is a late bound MSForms.DataObject
do.SetText TSV
do.PutInClipboard
ActiveSheet.Paste
Sub Test()
ParseString1 "A,B,C;D,E,F;G,H,I,J,K,L"
ParseString2 "A,B,C;D,E,F;G,H,I,J,K,L"
End Sub
Sub ParseString1(data As String)
Dim clip As MSForms.DataObject
Set clip = New MSForms.DataObject
data = Replace(data, ",", vbTab)
data = Replace(data, ";", vbCrLf)
clip.SetText data
clip.PutInClipboard
Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
End Sub
Sub ParseString2(data As String)
Dim aColumns, aRows
Dim x As Long
aRows = Split(data, ";")
For x = 0 To UBound(aRows)
aColumns = Split(aRows(x), ",")
Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(1, UBound(aColumns) + 1) = aColumns
Next
End Sub
You'll need to set a reference to the Microsoft Forms 2.0 Object Library if you use ParseString1.
Related
I am working on a script which selects only the needed slicer items. I tried using .SlicerItems.Selected = True / False for selecting and deselecting but I am using an OLAP data source in which case .Selected is read-only. The slicer items are in the format of YYYYWW so 7th week of 2018 would be 201807.
I recorded a macro selecting some slicer items and this is what it gave me:
Sub Macro2()
ActiveWorkbook.SlicerCaches("Slicer_YYYYWW").VisibleSlicerItemsList = Array( _
"[Results].[YYYYWW].&[201726]", "[Results].[YYYYWW].&[201727]", _
"[Results].[YYYYWW].&[201728]", "[Results].[YYYYWW].&[201729]", _
"[Results].[YYYYWW].&[201730]", "[Results].[YYYYWW].&[201731]", _
"[Results].[YYYYWW].&[201732]", "[Results].[YYYYWW].&[201733]", _
"[Results].[YYYYWW].&[201734]", "[Results].[YYYYWW].&[201735]", _
"[Results].[YYYYWW].&[201736]", "[Results].[YYYYWW].&[201737]", _
"[Results].[YYYYWW].&[201738]", "[Results].[YYYYWW].&[201739]", _
"[Results].[YYYYWW].&[201740]", "[Results].[YYYYWW].&[201741]", _
"[Results].[YYYYWW].&[201742]", "[Results].[YYYYWW].&[201743]", _
"[Results].[YYYYWW].&[201744]", "[Results].[YYYYWW].&[201745]", _
"[Results].[YYYYWW].&[201746]", "[Results].[YYYYWW].&[201747]", _
"[Results].[YYYYWW].&[201748]", "[Results].[YYYYWW].&[201749]", _
"[Results].[YYYYWW].&[201750]", "[Results].[YYYYWW].&[201751]", _
"[Results].[YYYYWW].&[201801]", "[Results].[YYYYWW].&[201802]", _
"[Results].[YYYYWW].&[201803]")
End Sub
So I tried following this template and create an array like that. This is how far I have gotten:
Sub arrayTest()
Dim startDate As Long
Dim endDate As Long
Dim n As Long
Dim i As Long
Dim strN As String
Dim sl As SlicerItem
Dim strArr As Variant
Dim dur As Long
Dim result As String
endDate = Range("C17").Value ' endDate is the last SlicerItem to be selected
startDate = Range("G17").Value ' startDate is the first SlicerItem to be selected
dur = Range("C19").Value ' duration is the the number of SlicerItems to be selected
i = 0
ReDim strArr(dur) As Variant
With ActiveWorkbook.SlicerCaches("Slicer_YYYYWW")
' .ClearManualFilter
For n = startDate To endDate
strN = CStr(n) ' convert n to string
If n = 201753 Then ' this is needed for when the year changes
strN = CStr(201801)
n = 201801
End If
strArr(i) = """[Results].[YYYYWW].&[" & strN & "]""" ' write string into array
i = i + 1
' For Each sl In .SlicerCacheLevels(1).SlicerItems
' If sl.Name = strN Then
' sl.Selected = True
' Else
' sl.Selected = False ' this is read-only for OLAP data so it's not working
' End If
' Next
Next
MsgBox Join(strArr, ", ") ' the MsgBox returns the correct string to be applied to select the right slicer items
.VisibleSlicerItemsList = Join(strArr, ", ") ' Error 13: Type mismatch
End With
End Sub
Currently, the code gives Error 13: Type mismatch on .VisibleSlicerItemsList = Join(strArr, ", "), which is also commented. So I'm guessing that either dimensioning strArr as Variant is wrong, the data is not inserted correctly into strArr or it's just impossible to do it this way. In the case of the latest one, how should I do it?
The part commented out on lines 29-35 does not work as it gives the usual error of Application-defined or object-defined error (1004) on sl.Selected = False.
I had a similar issue to overcome. Which I resolved using the following code:
Sub show_SlicerItems()
Dim sc As SlicerCache
Dim sL As SlicerCacheLevel
Dim si As SlicerItem
Dim slicerItems_Array()
Dim i As Long
Application.ScreenUpdating = False
Set sc = ActiveWorkbook.SlicerCaches("Slicer_Name")
Set sL = sc.SlicerCacheLevels(1)
ActiveWorkbook.SlicerCaches("Slicer_Name").ClearManualFilter
i = 0
For Each si In sL.SlicerItems
ReDim Preserve slicerItems_Array(i)
If si.Value <> 0 Then
slicerItems_Array(i) = si.Name
i = i + 1
End If
Next
sc.VisibleSlicerItemsList = Array(slicerItems_Array)
Application.ScreenUpdating = True
End Sub
You need to feed .VisibleSlicerItemsList an array, not a string. Ditch the Join.
And your strArr assignment should be like this: strArr(i) = "[Results].[YYYYWW].&[" & strN & "]" i.e. you don't need to pad it out with extra "
Edit: Out of interest, I happen to be building a commercial add-in that is effectively a Pop-up Slicer, that allows you to filter an OLAP PivotTable to show all items between a range like you are attempting to do. It also lets you filter on wildcards, crazy combinations of AND and OR, and filter on lists stored in external ranges.
Here's a screenshot of it in action. Note there is a search bar up the top that lets you use < or > together to set lower and upper limits, which is what I've done in the current Search. And you can see the result: it has correctly identified the 14 items from the PivotField that fit the bill.
All I need to do to filter the PivotTable on these is click the "Filter on selected items" option, and it does just that:
But working out how to do this - particularly given the limitations of the PivotTable object model (especially where OLAP PivotTables are concerned) was a VERY long term project, with many, many hurdles to overcome to make it work seamlessly. I can't share the code I'm afraid, as this is a commercial offering that I aim to release shortly. But I just wanted to highlight that while this is certainly possible, you are going to be biting off quite a bit if you want it to not throw errors when items don't exist.
Forget my other answer...you can use the Labels Filter to do this easily, provided the field of interest is in the PivotTable as either a Rows or Columns field. Fire up the Macro Recorder, and do the following:
...and you'll see that the PivotTable gets filtered:
...and the resulting code is pretty simple:
ActiveSheet.PivotTables("PivotTable1").PivotFields("[Table1].[YYYYWW].[YYYYWW]" _
).PivotFilters.Add2 Type:=xlCaptionIsBetween, Value1:="201726", Value2:= _
"201803"
Use this:
Sub seleciona_lojas()
Dim strArr()
Dim x As Long
Dim i As Long
For x = 2 To 262
ReDim Preserve strArr(i)
strArr(i) = "[Lojas].[Location_Cd].&[" & Planilha5.Range("B" & x).Value & "]"
i = i + 1
Next x
ActiveWorkbook.SlicerCaches("SegmentaçãodeDados_Location_Cd1").VisibleSlicerItemsList = strArr
End Sub
my goal is to write a function that converts returns to prices.
I have a vector of returns stored inside a range in excel like this:
r1
r2
...
rn
Now suppose that these returns are stored in Column B.
In VBA wrote the following code
Dim r As Range
Set r = ThisWorkbook.Sheets("Foglio1").Range("B2:B" & _
ThisWorkbook.Sheets("Foglio1").Range("B" & Rows.Count).End(xlUp).Row)
Dim temp() As Variant
temp = r
So I succesfully assigned the value r1, r2, ..., rn to an array that I called temp.
Now if I were in R or MATLAB I would have done the following, in order to convert return to prices:
temp = cumprod(1 + temp)
with one line of command I would have converted returns to prices
(1 + temp) should sum 1 to each element of array and cumprod should return me a vector with the cumulative product.
Is it possible that to achieve the same result I am forced to use for loop in VBA?
thank you very much for your time
have a great week end
Yes the only way to do this directly in VBA is with loops.
It is also possible to do it indirectly in VBA by using Excel Worksheet functions, but its actually usually faster to copy the range into a VBA array as you are doing and then process it with loops.
You can also write (or find and download) libraries that have callable functions and subroutines to hide the Loops from you, but they're still doing the loops.
As one comment said "Learn to love the loops". That's just how it works in VBA.
Ironically, I think the actual fastest way to do this would be to add a new column, let's say starting at Z2 that had Z2=B2+1 and every other row/cell was Z*=(B*+1)*Z[*-1].
You could do with SQL maybe?
This worked for my testing
Public Function PRODUCT_FUNCTION(strRange As String)
Dim c As ADODB.Connection
Dim r As ADODB.Recordset
strInputFile = ThisWorkbook.FullName
Set c = New ADODB.Connection
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strInputFile & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No"";"
c.ConnectionString = strConnectionString
c.Open
strsql = "Select Exp(Sum(Log([F1]))) from [Sheet1$" & strRange & "]"
Set r = New ADODB.Recordset
r.Open strsql, c, 1
PRODUCT_FUNCTION = r.Fields(0).Value
r.Close
c.Close
Set r = Nothing
Set c = Nothing
End Function
there's actually a way exploiting PasteSpecial() method of Range object and WorksheetFunction.Product() method:
Function CumulativeDiscount(discountsRng As Range) As Double
With discountsRng
.Copy
With .Offset(, .Parent.UsedRange.Columns.Count)
.Value = 1
.PasteSpecial , Operation:=xlPasteSpecialOperationAdd
Application.CutCopyMode = False
CumulativeDiscount = WorksheetFunction.Product(Application.Transpose(.Cells))
.ClearContents
End With
End With
End Function
that you could use in your "main" code as follows:
Sub main()
With ThisWorkbook.Sheets("Foglio1")
MsgBox CumulativeDiscount(.Range("B2", .Cells(.Rows.Count, "B").End(xlUp)))
End With
End Sub
the only limitation being WorksheetFunction.Product() accepts up to 30 arguments, i.e. the maximum number of discounts to be multiplied is 30
I am trying to feed data from an Excel sheet array (Udaje) to populate a several word documents from a template (hence the For in the example). I would like to insert some of the data to several Content Controls (text) at the same time. I am calling them by Tags and I know that I have to specify by adding .Item() - but then I only update one of the Content Controls.
Is there any way to overcome this restriction? I was thinking about cycling the tags with for but it seems to be a bit clumsy as I do not know how many tags I have to go through. I am a beginner at the VBA.
Or should I be using bookmarks instead?
For i = 1 To LastRow
'.SelectContentControlsByTag("NapRozhodnuti").Item(1).Range.Text = Udaje(i, 4)
.SelectContentControlsByTag("ZeDne").Item(1).Range.Text = Udaje(i, 5)
.SelectContentControlsByTag("NapadRozkladu").Item(1).Range.Text = Udaje(i, 6)
.SelectContentControlsByTag("Ucastnik").Item(1).Range.Text = Udaje(i, 2)
.SelectContentControlsByTag("DatumRK").Item(1).Range.Text = DatumRK
.SelectContentControlsByTag("NavrhRK").Item(1).Range.Text = NavrhRK
.SelectContentControlsByTag("OblastRK").Item(1).Range.Text = OblastRK
.SelectContentControlsByTag("Tajemnik").Item(1).Range.Text = Tajemnik
.SelectContentControlsByTag("Gender").Item(1).Range.Text = Gender
.SaveAs2 Filename:= i & " - dokumenty_k_RK.docx", _
FileFormat:=wdFormatDocument
Next i
Edit: the solution I chose in the end was to go through CCs in the document according to their Index number and set the value of each CC according to its tag:
For i = 1 To LastRow
For y = 1 To CCNumber
Select Case .ContentControls(y).Tag
Case "NapRozhodnuti"
.ContentControls(y).Range.Text = Udaje(i, 4)
Case "ZeDne"
.ContentControls(y).Range.Text = Udaje(i, 5)
Case "NapadRozkladu"
.ContentControls(y).Range.Text = Udaje(i, 6)
Case "Ucastnik"
.ContentControls(y).Range.Text = Udaje(i, 2)
Case "DatumRK"
.ContentControls(y).Range.Text = DatumRK
Case "NavrhRK"
.ContentControls(y).Range.Text = NavrhRK
Case "OblastRK"
.ContentControls(y).Range.Text = OblastRK
Case "Tajemnik"
.ContentControls(y).Range.Text = Tajemnik
Case "Gender"
.ContentControls(y).Range.Text = Gender
End Select
Next y
.SaveAs2 Filename:="..." & i & " - dokumenty_k_RK.docx", _
FileFormat:=wdFormatDocument
Next i
Edit: loop code
...
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "\\fs1\homes\rostislav.janda\Documents\320\pozvanka_prazdna.docx"
With objWord.ActiveDocument
Set ccs = .SelectContentControlsByTag("Spznrozkladu")
LoopCCs ccs, Udaje(i, 1)
.SaveAs2 Filename:="\\fs1\homes\rostislav.janda\Documents\320\výstup\pozvanka.docx", _
FileFormat:=wdFormatDocument 'uloží s formátem .docx
.Saved = True
End With
objWord.Quit
Set objWord = Nothing
End Sub
*Sub LoopCCs(ccs As Word.ContentControls, val As String)*
Dim cc As Word.ContentControl
For Each cc In ccs
cc.Range.Text = val
Next cc
End Sub
The Suprocedure declaration line is where the error ocurres.
Even though you've already found an approach that works for you, here's a tip that bases on the starting point you provide in your Question. You're using SelectContentControlsByTag, then only addressing the first of the controls found, using .Item(1).
This method returns an array of content controls and you don't have to know, going in, how many: you can use a For Each loop to cycle through as many as there are in the array. And so that you don't need to repeat the code of the loop for each tag, put that in a separate procedure, passing the array plus the value to be assigned to content controls with the same tag to it.
So something like this:
With doc
'Like this
Set ccs = .SelectContentControlsByTag("test")
LoopCCs ccs, Udaje(i, 4)
'Or like this
LoopCCs .SelectContentControlsByTag("ZeDne"), Udaje(i, 5)
End With
'Code is VBA and demonstrates the Word object model data types
'For VBS don't declare as types or type as Object
Sub LoopCCs(ccs as Word.ContentControls, val as String)
Dim cc as Word.ContentControl
For Each cc In ccs
cc.Range.Text = val
Next cc
End Sub
To do it using the Custom XML Part way, you could use the following code. As it stands, it needs to be in a single module.
You would use replaceAndLinkCxp to create/recreate the necessary Custom XML Part (i.e. it's a one off).
You would use linkedTaggedCcsToCxps to link/relink your Tagged content controls to the correct Cxp/Element (also a one-off). To work with the document, it would probably be simpler to create a Content Control for each tag, connect them using this routine, then create an autotext for the control.
You would use something based on populateCxpData to put the data in your Cxp.
There are quite a few assumptions (e.g. all the content controls are plain text, Element names are the same as tag names) and plenty of scope for improvement.
' This should be a name that belongs to you/your organisation
' It should also be unique for each different XML part structure
' you create. i.e. if you have one XML part with elements a,b,c
' and another with elements a,b,d, give them different namespace
' names.
Const sNameSpace = "hirulau"
' Specify the root element name for the part
Const sRootElementName = "ccdata"
Sub replaceAndLinkCxp()
' This deletes any existing CXP with the namespace specified
' in sOldNamespace, and creates a new CXP with the namespace
' in sNamespace. Any data in the CXP is lost.
' Then it links each Content Control with a tag name
' the same as an Element name in the part
' The old namespace (can be the same as the new one)
Const sOldNamespace = "hirulau"
Dim cc As Word.ContentControl
Dim ccs As Word.ContentControls
Dim cxp As Office.CustomXMLPart
Dim cxps As Office.CustomXMLParts
Dim i As Long
Dim s As String
' Specify the number and names of the elements and tags
' Each Element name should be unique, and a valid XML Element name
' and valid Content Control Tag Name
' (No nice way to do this in VBA - could just have a string and split it)
' NB, your CC tag names do not *have* to be the same as the XML Element
' names, but in this example we are making them that way
Dim sElementName(8) As String
sElementName(0) = "NapRozhodnuti"
sElementName(1) = "ZeDne"
sElementName(2) = "NapadRozkladu"
sElementName(3) = "Ucastnik"
sElementName(4) = "DatumRK"
sElementName(5) = "NavrhRK"
sElementName(6) = "OblastRK"
sElementName(7) = "Tajemnik"
sElementName(8) = "Gender"
' remove any existing CXPs with Namespace sOldNamespace
Set cxps = ActiveDocument.CustomXMLParts.SelectByNamespace(sOldNamespace)
For Each cxp In cxps
cxp.Delete
Next
Set cxps = Nothing
'Debug.Print ActiveDocument.CustomXMLParts.Count
' Build the XML for the part
s = "<" & sRootElementName & " xmlns=""" & sNameSpace & """>" & vbCrLf
For i = LBound(sElementName) To UBound(sElementName)
s = s & " <" & sElementName(i) & " />" & vbCrLf
Next
s = s & "</" & sRootElementName & ">"
'Debug.Print s
' Create the Part
Set cxp = ActiveDocument.CustomXMLParts.Add(s)
' For each element/tag name, find the ccs with the tag
' and connect them to the relevant element in the part
For i = LBound(sElementName) To UBound(sElementName)
For Each cc In ActiveDocument.SelectContentControlsByTag(sElementName(i))
' the "map:" is just a local mapping to the correct namespace.
' It doesn't have any meaning outside this method call.
cc.XMLMapping.SetMapping "/map:" & sRootElementName & "/map:" & sElementName(i) & "[1]", "xmlns:map=""" & sNameSpace & """", cxp
Next
Next
Set cxp = Nothing
End Sub
Sub linkTaggedCcsToCxps()
' Finds our Custom part, then relinks all controls with
' tag names that correspond to its *top level element names*
' So as long as you tag a suitable content control correctly,
' you can use this routine to make it point at the correct Cxp Element
Dim cc As Word.ContentControl
Dim cxn As Office.CustomXMLNode
Dim cxps As Office.CustomXMLParts
' Notice that we need the correct namespace name to do this
Set cxps = ActiveDocument.CustomXMLParts.SelectByNamespace(sNameSpace)
If cxps.Count = 0 Then
MsgBox "Could not find the expected Custom XML Part."
Else
' Iterate through all the *top-level* child Element nodes
For Each cxn In cxps(1).SelectNodes("/*/*")
For Each cc In ActiveDocument.SelectContentControlsByTag(cxn.BaseName)
' the "map:" is just a local mapping to the correct namespace.
' It doesn't have any meaning outside this method call.
cc.XMLMapping.SetMapping "/map:" & sRootElementName & "/map:" & cxn.BaseName & "[1]", "xmlns:map=""" & sNameSpace & """", cxps(1)
Next
Next
End If
Set cxps = Nothing
End Sub
Sub populateCxpData()
Dim sXpPrefix As String
' You would need to populate the following things
Dim i As Integer
Dim Udaje(1, 6) As String
Dim DatumRK As String
Dim NavrhRK As String
Dim OblastRK As String
Dim Tajemnik As String
Dim Gender As String
i = 1
' we need the namespace, but this time assume that we can use
' the first part with that namespace (and that it exists)
With ActiveDocument.CustomXMLParts.SelectByNamespace(sNameSpace)(1)
sXpPrefix = "/*/" & .NamespaceManager.LookupPrefix(sNameSpace) & ":"
.SelectSingleNode(sXpPrefix & "NapRozhodnuti[1]").Text = Udaje(i, 4)
.SelectSingleNode(sXpPrefix & "ZeDne[1]").Text = Udaje(i, 5)
.SelectSingleNode(sXpPrefix & "NapadRozkladu[1]").Text = Udaje(i, 6)
.SelectSingleNode(sXpPrefix & "Ucastnik[1]").Text = Udaje(i, 2)
.SelectSingleNode(sXpPrefix & "DatumRK[1]").Text = DatumRK
.SelectSingleNode(sXpPrefix & "NavrhRK[1]").Text = NavrhRK
.SelectSingleNode(sXpPrefix & "OblastRK[1]").Text = OblastRK
.SelectSingleNode(sXpPrefix & "Tajemnik[1]").Text = Tajemnik
.SelectSingleNode(sXpPrefix & "Gender[1]").Text = Gender
End With
End Sub
I am writing VBA code for an Excel workbook. I would like to be able to open a connection with an Access database, and then import a txt file (pipe delimited) and create a new table in the database from this txt file. I have searched everywhere but to no avail. I have only been able to find VBA code that will accomplish this from within Access itself, rather than from Excel. Please help! Thank you
Google "Open access database from excel VBA" and you'll find lots of resources. Here's the general idea though:
Dim db As Access.Application
Public Sub OpenDB()
Set db = New Access.Application
db.OpenCurrentDatabase "C:\My Documents\db2.mdb"
db.Application.Visible = True
End Sub
You can also use a data access technology like ODBC or ADODB. I'd look into those if you're planning more extensive functionality. Good luck!
I had to do this exact same problem. You have a large problem presented in a small question here, but here is my solution to the hardest hurdle. You first parse each line of the text file into an array:
Function ParseLineEntry(LineEntry As String) As Variant
'Take a text file string and parse it into individual elements in an array.
Dim NumFields As Integer, LastFieldStart As Integer
Dim LineFieldArray() As Variant
Dim i As Long, j As Long
'Determine how many delimitations there are. My data always had the format
'data1|data2|data3|...|dataN|, so there was always at least one field.
NumFields = 0
For I = 1 To Len(LineEntry)
If Mid(LineEntry, i, 1) = "|" Then NumFields = NumFields + 1
Next i
ReDim LineFieldArray(1 To NumFields)
'Parse out each element from the string and assign it into the appropriate array value
LastFieldStart = 1
For i = 1 to NumFields
For j = LastFieldStart To Len(LineEntry)
If Mid(LineEntry, j , 1) = "|" Then
LineFieldArray(i) = Mid(LineEntry, LastFieldStart, j - LastFieldStart)
LastFieldStart = j + 1
Exit For
End If
Next j
Next i
ParseLineEntry = LineFieldArray
End Function
You then use another routine to add the connection in (I am using ADODB). My format for entries was TableName|Field1Value|Field2Value|...|FieldNValue|:
Dim InsertDataCommand as String
'LineArray = array populated by ParseLineEntry
InsertDataCommand = "INSERT INTO " & LineArray(1) & " VALUES ("
For i = 2 To UBound(LineArray)
If i = UBound(LineArray) Then
InsertDataCommand = InsertDataCommand & "'" & LineArray(i) & "'" & ")"
Else
InsertDataCommand = InsertDataCommand & LineArray(i) & ", "
End If
Next i
Just keep in mind that you will have to build some case handling into this. For example, if you have an empty value (e.g. Val1|Val2||Val4) and it is a string, you can enter "" which will already be in the ParseLineEntry array. However, if you are entering this into a number column it will fail on you, you have to insert "Null" instead inside the string. Also, if you are adding any strings with an apostrophe, you will have to change it to a ''. In sum, I had to go through my lines character by character to find these issues, but the concept is demonstrated.
I built the table programmatically too using the same parsing function, but of this .csv format: TableName|Field1Name|Field1Type|Field1Size|...|.
Again, this is a big problem you are tackling, but I hope this answer helps you with the less straight forward parts.
I'm using the code below to separate a group of strings separated by a comma (,), then saves the output in a string variable named, msg. Strings in variable msg is separated by vbNewLine.
For example:
Original string for example is fruits, contains: apple, mango, orange
after applying the function splittext(fruits)
the variable now msg contains: apple <vbNewLine> mango <vbNewLine> orange
Now, I wanted to separate the content of this msg to cell(each string).
For example, mango is in A1, apple is in A2, orange is in A3 (on a different sheet.
I tried 'ActiveWorkbooks.Sheets("Sheet2").Range("A" & i).Value = Cs(i), (see the code below). But it's not working. After the execution, the cells in the sheet2 remains unchanged. I really need your help. Thanks.
Function splittext(input_string As String) As String
Dim SptTxt As String
Dim Cs As Variant
Dim CsL As Byte
Dim CsU As Byte
Dim i As Byte
Dim col As Collection
Set col = New Collection
Cs = Split(input_string, ",")
CsL = LBound(Cs)
CsU = UBound(Cs)
Dim msg As String
For i = CsL To CsU
ReDim arr(1 To CsU)
col.Add Cs(i)
msg = msg & Cs(i) & vbNewLine
'ActiveWorkbooks.Sheets("Sheet2").Range("A" & i).Value = Cs(i)
Next
splittext = msg
End Function
Here's your macro refactored to give the results you describe, without any looping.
Function splittext(input_string As String) As String
Dim Cs As Variant
Cs = Split(input_string, ",")
splittext = Join(Cs, vbNewLine)
' Put results into workbook
With ActiveWorkbook.Sheets("Sheet2")
Range(.[A1], .Cells(UBound(Cs) + 1, 1)).Value = Application.Transpose(Cs)
End With
End Function
Note that copying an array to a range requires a 2 dimensional array, rows x columns. Transpose is a handy function to convert a 1 dim array to a 2 dim array
EDIT
Note that if you call this as a user-defined function (UDF) from a cell (as you are in the sample file) it will fail (If it is called from a VBA Sub it will work). This is because a UDF cannot modify anything in Excel, it can only return to the calling cell (there is a rather complex workaround, see this answer.) If you remove the With section it does work as a UDF.
If what you are trying to return the list into multiple cells, consider using an array function.
You have to use it like that:
ActiveWorkbook.Sheets("Sheet2").Range("A" & i+1).Value = Cs(i)
You try to write in the Cell "A0" because "i" is in the First loop zero. And this is not working because there is no cell "A0".
And you had an "s" by ActiveWorkbook.
Moosli