I've been wraping my head around it for some time and just don't know how to approach this problem. My table consists of groups of data which I want to transpose from rows to columns. Every row has an index number in first column and all of the rows in one group have the same index.
1 a
1 b
1 c
1 d
1 e
1 f
1 g
1 h
2 as
2 bs
2 cs
5 ma
5 mb
5 mc
5 md
and I want my final result to be:
1 a b c d e f g h
2 as bs cs
5 ma mb mc md
is it possible to do this with formulas or do I have to do it in VBA?
You can also do this using a macro. Here is one method.
To enter this Macro (Sub), alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.
To use this Macro (Sub), alt-F8 opens the macro dialog box. Select the macro by name, and RUN.
Option Explicit
Sub ReArrange()
Dim vSrc As Variant, rSrc As Range
Dim vRes As Variant, rRes As Range
Dim I As Long, J As Long, K As Long
Dim lColsCount As Long
Dim Col As Collection
'Upper left cell of results
Set rRes = Range("D1")
'Assume Data in A1:Bn with no labels
Set rSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=2)
'Ensure Data sorted by index number
rSrc.Sort key1:=rSrc.Columns(1), order1:=xlAscending, key2:=rSrc.Columns(2), order2:=xlAscending, MatchCase:=False, _
Header:=xlNo
'Read Source data into array for faster processing
' compared with going back and forth to worksheet
vSrc = rSrc
'Compute Number of rows = unique count of index numbers
'Collection object can only have one entry per key
' otherwise it produces an error, which we skip
Set Col = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc)
Col.Add Item:=vSrc(I, 1), Key:=CStr(vSrc(I, 1))
Next I
On Error GoTo 0
'Compute Maximum Number of columns in results
' Since there is one entry per Index entry, maximum number of
' columns will be equal to the Index that has the most lines
' So we iterate through each Index and check that.
For I = 1 To Col.Count
J = WorksheetFunction.CountIf(rSrc.Columns(1), Col(I))
lColsCount = IIf(J > lColsCount, J, lColsCount)
Next I
'Set up Results array
' Need to add one to the columns to account for the column with the Index labels
ReDim vRes(1 To Col.Count, 1 To lColsCount + 1)
'Now populate the results array
K = 1
For I = 1 To Col.Count
vRes(I, 1) = vSrc(K, 1)
J = 2
Do
vRes(I, J) = vSrc(K, 2)
J = J + 1: K = K + 1
If K > UBound(vSrc) Then Exit Do
Loop Until vSrc(K, 1) <> vRes(I, 1)
Next I
'Set the results range to be the same size as our array
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1), columnsize:=UBound(vRes, 2))
'Clear the results range and then copy the results array to it
rRes.EntireColumn.Clear
rRes = vRes
'Format the width. Could also format other parameters
rRes.EntireColumn.ColumnWidth = 10
End Sub
Yes its possible. You would need the following functions:
IF
MATCH
ISNA
INDEX
Assume you have the data in sheet 1 in columns A and B:
C1:
place the value "1" in cell C1
C2:
=C1+1
drag down as much as needed
D1
=MATCH(C1,A:A, 0)
Drag down as much as cell C2
E1
=MATCH(C1,A:A, 1)
Drag down as much as cell C2
Sheet 2:
Now place the following formulas in cell A1 in sheet2:
=IF(ISNA(Sheet1!$D1), "", IF(Sheet1!$D1="", "", IF(COLUMN()-1+Sheet1!$D1 <=Sheet1!$E1, INDEX(Sheet1!$B:$B, COLUMN()-1+Sheet1!$D1), "")))
Drag / Copy it to as many cells as needed:
Result:
Also I have an article on my blog about the INDEX function. It might help Excel INDEX Function.
You can also download the complete file here.
Related
Last summer, I made a pretty basic VBA for an inventory sheet. Column A lists item name, and column B, C, and D are additional info for each item listed. The inventory is two-columned (A2:D28 and G2:J28). The VBA I made makes it so that if I delete the item entry in cell A4, the info in cells B4:D4 clears automatically with it.
The question is: I've been struggling to find a way to make the cells shift up a row when the row above it is cleared, to prevent the list from accumulating empty rows as inventory items are deleted. Most examples I found online were to delete those empty cells, whereas I'd rather just clear them and keep my formatting intact.
Is there a way to shift specific cells up like that? And, it would be lovely if there was a way to shift items from the top of the second table (G2:J2) down and over to the bottom of the first table, into A28:D28.
Any help would be greatly appreciated, or even a thumb towards a relevant tutorial. Thank you!
This code is a little tricky because of the two columns you have on your screen. My code below reads the two columns into a single one, sorts blank rows to the bottom and then splits the resulting single column back into two. All of this is done without touching the cells themselves. Therefore formatting stays in place.
Option Explicit
Enum Nsp ' Table specs
' 023
' These enumerations define your table. Modify to suit
NspAnchorClm = 1 ' 1 = column A
NspTblClmCount = 4 ' number of Table Columns
NpsSpaceClmCount = 2 ' number of blank sheet columns between List Columns
NspListClmCount = 2 ' number of List Columns
NspFirstRow = 2
NspNumRows = 10 ' number of rows per List Column
End Enum
Sub ResetList()
' 023
Dim Clm() As Variant ' First sheet column of each list column
Dim ArrIn As Variant ' Input data array
Dim Cin As Long ' input column counter
Dim Rin As Long ' input row counter
Dim ArrOut As Variant ' Output data array
Dim Rout As Long ' output row counter
Dim Rng As Range ' the sheet range of varying dimension
Dim Tmp As Variant ' intermediate memory
Dim L As Integer ' List column counter
Dim C As Long ' column counter
Dim R As Long ' row counter
Clm = Array(NspAnchorClm, NspAnchorClm + NspTblClmCount + NpsSpaceClmCount)
Tmp = (NspTblClmCount * NspListClmCount) + (NpsSpaceClmCount * (NpsSpaceClmCount - 1))
Set Rng = Range(Cells(NspFirstRow, Clm(0)), _
Cells(NspFirstRow + NspNumRows - 1, Tmp))
' read all of the list into an array
ArrIn = Rng.Value
' define a single list column array
ReDim ArrOut(1 To NspNumRows * NspListClmCount, 1 To NspTblClmCount)
' transfer the data to a single list column
For L = 1 To NspListClmCount
For R = 1 To NspNumRows
Rout = (L - 1) * NspNumRows + R
For C = 1 To NspTblClmCount
Cin = Clm(L - 1) + C - 1
ArrOut(Rout, C) = ArrIn(R, Cin)
Next C
Next R
Next L
' ArrIn is cleared and re-purposed to take data from ArrOut
ReDim ArrIn(1 To UBound(ArrOut), 1 To UBound(ArrOut, 2))
Rin = 0
For Rout = 1 To UBound(ArrOut)
' skip rows where the first column is blank
If Len(ArrOut(Rout, 1)) Then
Rin = Rin + 1
For C = 1 To UBound(ArrOut, 2)
ArrIn(Rin, C) = ArrOut(Rout, C)
Next C
End If
Next Rout
' assign NspNumRows high sections of ArrIn to ArrOut
For L = 1 To NspListClmCount
ReDim ArrOut(1 To NspNumRows, 1 To NspTblClmCount)
For R = 1 To NspNumRows
For C = 1 To NspTblClmCount
ArrOut(R, C) = ArrIn(((L - 1) * NspNumRows) + R, C)
Next C
Next R
Set Rng = Cells(NspFirstRow, Clm(L - 1)).Resize(NspNumRows, NspTblClmCount)
Rng.Value = ArrOut
Next L
End Sub
I'm afraid this code will make the code you already have obsolete. If the first cell in a row is empty any content in the others will be omitted, just like your own code does.
Please pay attention to the enumeration at the top of the code. It works like a switchboard where you can enter all parameters. You can modify them as you wish. For example my code has NspNumRows = 10. Your sheet has 27 data rows per column. You will need to change that number. Just to help you find your way:-
The "AnchorColumn" is the first sheet column of the first list column. All other columns are counted from there. It need not be column A. You could leave column A blank and anchor your list in Column B (=2).
"TableColumns" are the columns that repeat in each "ListColumn". You can have more than 4 or fewer.
A "ListColumn" consists of several "TableColumns". You can have more than 2.
"SpaceColumns" are blank sheet columns inserted between "ListColumns".
NspFirstRow specifies the first data row. Above it are captions or other data which this program doesn't touch on. You could reserve the first 10 rows for something else and start your list in row 11.
By setting these 6 enumerations you can create lists of 2 or more List Columns, anywhere on the worksheets, with any number of data rows. Not all of this has been tested exhaustively. When you delete a row anywhere (in fact only the first cell of that row) the list is rewritten to move the blank row to the bottom of the last list column.
I have a sheet with data in 2 columns, A and B:
--A-- --B--
Apple 57
Orange 62
Lime 45
Orange 58
Apple 57
What I want is, I need to search column A for duplicates, then if there are any, look for their value in column B. If they are different, I want to color the cell in column A to red, show the other value of that entry in column C, and show a message on how many indifferences there are. Something like this:
--A-- --B-- --C--
Apple 57
Orange 62 58
Lime 45
Orange 58 62
Apple 57
Please help me with this, I know how to compare the value in one column, but then don't know how to search for additional value for them in the other column.
Since i am still at learning process it may not be the best solution but it seems it is working
```
' inoG
Sub Solution()
Dim rows As Integer
rows = Range("a1").End(xlDown).Row 'Getting total row number
Dim dt As Variant
dt = Range("a1:c" & rows) 'data into array '
'forward search
For i = 1 To rows
For j = i + 1 To rows
If dt(i, 1) = dt(j, 1) And dt(i, 2) <> dt(j, 2) Then
dt(i, 3) = dt(j, 2)
GoTo Continue1
End If
Next j
Continue1:
Next i
'backward search
For i = rows To 1 Step -1
For j = i - 1 To 1 Step -1
If dt(i, 1) = dt(j, 1) And dt(i, 2) <> dt(j, 2) Then
dt(i, 3) = dt(j, 2)
GoTo Continue2
End If
Next j
Continue2:
Next i
'filling row C and Highlighting
For i = 1 To rows
If Not IsEmpty(dt(i, 3)) Then
Cells(i, 3) = dt(i, 3)
Range("A" & i).Interior.ColorIndex = 3
End If
Next i
'Final Message
Dim totdif As Integer
totdif = WorksheetFunction.CountA(Range("C1:C1" & rows))
MsgBox totdif
End Sub
My following solution used a helper column to rank the values in Column B per item in Column A using COUNTIFS function. Then I used a pivot table to show the average value of each rank for each item.
Presume you have following named ranges:
ListItem being your data in Column A;
ListValue being your data in Column B.
The formula in Cell C2 is:
=IF(COUNTIFS(ListItem,A2,ListValue,">"&B2)+1>1,"2nd Value","1st Value")
Change the cell references used to suit your case.
This solution will create an output table laying out all the unique items and then populate the two different values (if there are two) in two consecutive columns next to each item. For comparison purpose I think a pivot table is sufficient and quite efficient.
P.s. to create a pivot table, you just need to highlight the source table, go to Insert tab, and click the Pivot Table button to generate a pivot table. Set up the fields in the following way and you will have something similar to my example:
EDIT #2
If you want to show the second value in Column C for each item, here is a formula based approach.
In Cell C2 enter the following formula and drag it down:
=IFERROR(AGGREGATE(14,6,AGGREGATE(14,6,ListValue/(ListItem=A2),ROW($Z$1:INDEX($Z:$Z,COUNTIF(ListItem,A2))))/((AGGREGATE(14,6,ListValue/(ListItem=A2),ROW($Z$1:INDEX($Z:$Z,COUNTIF(ListItem,A2))))<>B2)),1),"")
The logic is to use ListValue/(ListItem=A2) to return a range of values for each item, then use AGGREGATE function to filter out all the errors, then use
AGGREGATE(14,6,ListValue/(ListItem=A2),ROW($Z$1:INDEX($Z:$Z,COUNTIF(ListItem,A2))))<>B2
to further filter the range to show the second value (which is different to the first value), then use AGGREGATE function again to return that value.
Let me know if you have any questions. Cheers :)
I think you can do this with formulas.
If you are concerned about users changing the formula, use a Table (and perhaps even protect the formula column, although this would require VBA code to allow expanding the table). That way the ranges will dynamically adjust to additions and deletions of data, and the users will not need to edit the formula:
With the table renamed Fruits, and the columns named as in the screenshot:
=IFERROR(AGGREGATE(14,6,1/(([#Fruit]=[Fruit])*([#Value]<>[Value]))*[Value],1),"")
Use Conditional Formatting to format the cells
EDIT:
I think the table approach would give you a better solution, but for a VBA approach I would use a Dictionary and a collection of the different values associated with the fruits.
Assuming your first column is named "Fruit" (or something you can use in Find, or even a known address), you can use the following to create a column of the alternate values for each item.
'Add reference to Microsoft Scripting Runtime
' or use late binding
Option Explicit
Sub diffs()
Dim myD As Dictionary
Dim vData As Variant
Dim rData As Range, C As Range
Dim wsSrc As Worksheet
Dim I As Long, V As Variant
Dim colVals As Collection
'Find the table
Set wsSrc = Worksheets("sheet2") 'or wherever
With wsSrc.Cells
Set C = .Find(what:="Fruit", after:=.Item(1, 1), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=True)
If Not C Is Nothing Then
With wsSrc
Set rData = .Range(C, .Cells(.Rows.Count, C.Column).End(xlUp)).Resize(columnsize:=3)
vData = rData
End With
Else
MsgBox "No data table"
Exit Sub
End If
End With
'Collect the data into a dictionary
'Max 2 different values per fruit
Set myD = New Dictionary
myD.CompareMode = TextCompare
For I = 2 To UBound(vData)
If Not myD.Exists(vData(I, 1)) Then
Set colVals = New Collection
colVals.Add Item:=vData(I, 2), Key:=CStr(vData(I, 2))
myD.Add Key:=vData(I, 1), Item:=colVals
Else
On Error Resume Next 'omit duplicate values
myD(vData(I, 1)).Add Item:=vData(I, 2), Key:=CStr(vData(I, 2))
On Error GoTo 0
End If
Next I
'Populate column 3
For I = 2 To UBound(vData, 1)
Set colVals = myD(vData(I, 1))
vData(I, 3) = ""
If colVals.Count > 1 Then
For Each V In colVals
If V <> vData(I, 2) Then vData(I, 3) = V
Next V
End If
Next I
Application.ScreenUpdating = False
With rData
.Clear
.Value = vData
For I = 2 To UBound(vData)
If vData(I, 3) <> "" Then
With rData.Cells(I, 1)
.Font.Color = vbWhite
.Font.Bold = True
.Interior.Color = vbRed
End With
End If
Next I
End With
End Sub
I have and excel document that looks like this:
and i want it to be like:
*comma (,) means that data are in different cells horizontally.
is there any vb macro or an expression to do it?
If all of the Rows have the same number of columns, then you can use INDEX, INT, COUNTA and MOD to break this down.
Column A:
=INDEX(Sheet1!$A$1:$D$2,1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),1)
Column B:
=INDEX(Sheet1!$A$1:$D$2,1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),2+MOD(ROW()-1,COUNTA(Sheet1!$1:$1)-1))
Where Sheet1!$A$1:$D$2 is the 'Input' range, and Sheet1!$1:$1 is any row in that range with a full row of data.
INDEX lets you get a specific row/column of a range. Our Range is Sheet1!$A$1:$D$2, and the Row is the same for both formulae:
1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),
This will be 1 for n rows, 2 for the next n, etc, where n is the number of cells in a row minus the starter column (i.e. how many names per gender)
(INT removes the decimal part of a number, so INT(3/4) is INT(0.75), which is 0. COUNTA just counts the non-blank cells)
The difference between the two is the Column. In column A, we just want the first column, so Column is 1. In column B, we want the xth item after the first column, where x A) counts up by 1 each row and B) resets to 1 when we go from Male to Female (or beyond)
Now, the MOD function lets us do that fairly simply: MOD(0, 3) is 0, MOD(1, 3) is 1, MOD(2, 3) is 2, and MOD(3, 3) is back to 0. We just need to start out row count at 0 (subtract 1 from Row, and add it back outside the MOD) and remove the first column from the items-per-row (subtract 1 from the COUNTA, add 1 outside the MOD)
A straightforward solution would be to use Split
Sub TransferIt()
Const SEP = ","
Dim rg As Range
Dim vdat As Variant
Dim lDat As Variant
Dim i As Long, j As Long
Dim col As Collection
' Assumption data is in column A, adjust accordingly
Set rg = Range("A1:A4")
vdat = WorksheetFunction.Transpose(rg)
Set col = New Collection
For i = LBound(vdat) To UBound(vdat)
lDat = Split(vdat(i), SEP)
For j = LBound(lDat) + 1 To UBound(lDat)
' first field always contains female or male
col.Add lDat(LBound(lDat)) & SEP & lDat(j)
Next j
Next i
vdat = collectionToArray(col)
' Write data into column B
Range("B1").Resize(UBound(vdat) + 1) = WorksheetFunction.Transpose(vdat)
End Sub
' Source: http://www.iwebthereforeiam.com/iwebthereforeiam/2004/06/excel-vba-code-to-convert-coll.html
Function collectionToArray(c As Collection) As Variant()
Dim a() As Variant: ReDim a(0 To c.Count - 1)
Dim i As Integer
For i = 1 To c.Count
a(i - 1) = c.Item(i)
Next
collectionToArray = a
End Function
Before:
After:
Code:
Sub settupp()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Activate
n = Cells(Rows.Count, 1).End(xlUp).Row
k = 1
For i = 1 To n
namee = Cells(i, 1).Value
For j = 2 To 4
numberr = Cells(i, j).Value
s2.Cells(k, 1) = namee
s2.Cells(k, 2) = numberr
k = k + 1
Next
Next
End Sub
I have been stuck on this for weeks and have tried many formula combinations but can't get this to work. I don't know VBA so don't know where to start there.
I have List 1 and List 2 below. I need List 3 to be created from the data in Lists 1 and 2. List 3 can, preferably, be created in a new sheet.
I need to lookup the criteria from Column A, in List2 (Column D) then return all matches in a new list that shows: List 1; the criteria (Column A), data in Column B; and all matches from List 2 (Column E)
See Below. List 3 is the outcome
I broke this into two parts and I tried using a formula that copied the row the amount of times that there was a match. Then I was going to copy paste or find some vba or formula to combine the table but I came to a dead end when I realized the they tables weren't sorted in the same order. I ended up with these two lists to combine
Tried this VBA
Getting this error
Try This.
Run the macro "Test"
The first parameter should be the range of your first list (Just the numbers)
The second parameter should be the range of your second list (Just the numbers)
OutputSheet should be the sheet you want to output the list on
You can also optionally set the output row and output column (It will start at A1 if you don't specify)
Sub CreateList(List1 As Range, List2 As Range, OutputSheet As Worksheet, Optional ORow As Long = 1, Optional OCol As Long = 1)
Dim c, d
For Each c In List1
For Each d In List2
If c = d Then
OutputSheet.Cells(ORow, OCol).Value = c.Value
OutputSheet.Cells(ORow, OCol + 1).Value = c.Offset(0, 1).Value
OutputSheet.Cells(ORow, OCol + 2).Value = d.Offset(0, 1).Value
ORow = ORow + 1
End If
Next d
Next c
End Sub
Sub Test()
With Sheets("Sheet1")
CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
End With
End Sub
The code loops through each number in the first list, and then each number in the second list.
If the numbers are the same, it outputs the number, the item, and the price.
First it will check If 10 = 10 Then - output the number, output the text next to the number on the first list, and output the amount next to the number on the second list.
Then it increases the row by 1.
That's pretty much all there is to it - just make sure you specify the ranges properly and change the sheet references as needed.
If you have never used VBA before, you can open the window by pressing ALT+F11
Right click to the left side and select Insert -> Module
Paste the code into the right side.
Update the ranges on the following line so they match where your lists are:
CreateList .Range("A2:A7"), .Range("D2:D6"), Sheets("Sheet2")
You can then close the window and press ALT+F8 to open the Run Macro dialog.
Select Test and click Run
Input:
Results:
What about this?
The code below assumes that on Sheet1, data starts from Row2 where Row1 is the header row.
Sub CreateList()
Dim x, y, z()
Dim i As Long, j As Long, k As Long, n As Long, dlr As Long
Dim wsData As Worksheet, wsOutput As Worksheet
Application.ScreenUpdating = False
Set wsData = Sheets("Sheet1")
On Error Resume Next
Set wsOutput = Sheets("List")
wsOutput.Cells.Clear
On Error GoTo 0
If wsOutput Is Nothing Then
Sheets.Add(after:=wsData).Name = "List"
Set wsOutput = ActiveSheet
End If
x = wsData.Range("A1").CurrentRegion.Value
y = wsData.Range("D1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
If Application.CountIf(wsData.Columns("D"), x(i, 1)) > 0 Then
n = Application.CountIf(wsData.Columns("D"), x(i, 1))
ReDim z(1 To n)
k = 1
For j = 2 To UBound(y, 1)
If y(j, 1) = x(i, 1) Then
z(k) = y(j, 2)
k = k + 1
End If
Next j
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
wsOutput.Range("A" & dlr).Value = x(i, 1)
wsOutput.Range("B" & dlr).Value = x(i, 2)
wsOutput.Range("C" & dlr).End(3)(2).Resize(UBound(z, 1), 1) = Application.Transpose(z)
End If
Erase z
Next i
dlr = wsOutput.Range("C" & Rows.Count).End(3)(2).Row
If dlr > 1 Then
wsOutput.Range("A2:C" & dlr).CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
wsOutput.Rows(1).Delete
End If
Application.ScreenUpdating = True
End Sub
I have the following column K in Excel:
K
2 Apps -
3 Appointed CA - Apps - Assist - Appointed NA - EOD Efficiency
4 Appointed CA -
5 Appointed CA -
I want to split at - and count the number occurrences of the specific words in the string.
I tried the following formula which splits my string and returns everything LEFT to the -
=LEFT( K2, FIND( "-", K2 ) - 2 )
But the ideal output should be:
Apps Appointed CA Assist Appointed NA EOD Efficiency
1
1 1 1 1 1
1
1
Based on the above data.
Regards,
Here is a VBA macro that will
Generate a unique list of phrases from all of the data
Create the "header row" containing the phrases for the output
Go through the original data again and generate the counts for each phrase
As written, the macro is case insensitive. To make it case sensitive, one would have change the method of generating the unique list -- using the Dictionary object instead of a collection.
To enter this Macro (Sub), alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and paste the code below into the window that opens. It should be obvious where to make changes to handle variations in where your source data is located, and where you want the results.
To use this Macro (Sub), alt-F8 opens the macro dialog box. Select the macro by name, and RUN.
It will generate results as per your ideal output above
Option Explicit
Option Compare Text
Sub CountPhrases()
Dim colP As Collection
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim I As Long, J As Long, K As Long
Dim V As Variant, S As String
'Set Source and Results worksheets and ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1) 'Results will start in A1 on results sheet
'Get source data and read into array
With wsSrc
vSrc = .Range("K2", .Cells(.Rows.Count, "K").End(xlUp))
End With
'Collect unique list of phrases
Set colP = New Collection
On Error Resume Next 'duplicates will return an error
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), "-")
For J = 0 To UBound(V)
S = Trim(V(J))
If S <> "" Then colP.Add S, CStr(S)
Next J
Next I
On Error GoTo 0
'Dimension results array
'Row 0 will be for the column headers
ReDim vRes(0 To UBound(vSrc, 1), 1 To colP.Count)
'Populate first row of results array
For J = 1 To colP.Count
vRes(0, J) = colP(J)
Next J
'Count the phrases
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), "-")
For J = 0 To UBound(V)
S = Trim(V(J))
If S <> "" Then
For K = 1 To UBound(vRes, 2)
If S = vRes(0, K) Then _
vRes(I, K) = vRes(I, K) + 1
Next K
End If
Next J
Next I
'write results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
Assuming result range starts in column L:
L2: =IF(FIND("Apps", K2, 1) <> 0, 1, "")
M2: =IF(FIND("Appointed CA", K2, 1) <> 0, 1, "")
etc.
Autofill downwards.
EDIT:
Assuming all possible string combinations we're looking for are known ahead of time, the following should work. If the possible string combinations are not known, I would recommend building a UDF to sort it all out.
Anyway, assuming the strings are known, following the same principle as above:
L2: =IF(FIND("Apps", K2, 1) <> 0, (LEN(K2) - LEN(SUBSTITUTE(K2, "Apps", "")) / LEN(K2)), "")
M2: =IF(FIND("Appointed CA", K2, 1) <> 0, (LEN(K2) - LEN(SUBSTITUTE(K2, "Appointed CA", "")) / LEN(K2)), "")
Increase for as many strings as you like, autofill downwards.