VBA count the number of multiple occurrences

[sr1111]

I am not very much an expert in excel. I am trying to count the number of occurrences of keys in columns A as in the below example.
The VBA needs to count how many times am1, anip1, zora1, riP-1, una1, aya1, im1, nd#1 appers under Com, eae and sae.
Is it possible?

Input:

DADPNI.xlsm
	A	B
1	Column A	Column B
2	am1 anip1 zora1 riP-1 una1 una1 aya1 im1 nd#1	Com ; sae ;eae ;%&*()1;
3	una1 aya1 im1 nd1 am1 anip1 zora1 riP-1	Com ;Com ;sae; eae; sae ;eae ;
4	am1 anip1 zora1 am1 anip1 zora1	sae ;eae ;%&*()1;
5	una1 aya1	eae ;sae
6	anip1 zora1
7	im1	;;; ;
8
9	aya1	eae ;sae ;eae ;sae sae;;
10	aya1 im1 riP-1	Com
11	im1	Com
Sheet1

Output:

DADPNI.xlsm
	A	B	C	D	E	F	G	H
1		Com	eae					sae
2	am1	4	5					?
3	anip1	1	4					4
4	zora1	2	?					?
5	riP-1	3	?					?
6	una1	3	?					?
7	aya1	3	?					?
8	im1	6	?					?
9	nd#1	1	?					?
Sheet2

 

[sr1111]

I am not very much an expert in excel. I am trying to count the number of occurrences of keys in columns A as in the below example.
The VBA needs to count how many times am1, anip1, zora1, riP-1, una1, aya1, im1, nd#1 appers under Com, eae and sae.
Is it possible?

Input:

DADPNI.xlsm
	A	B
1	Column A	Column B
2	am1 anip1 zora1 riP-1 una1 una1 aya1 im1 nd#1	Com ; sae ;eae ;%&*()1;
3	una1 aya1 im1 nd1 am1 anip1 zora1 riP-1	Com ;Com ;sae; eae; sae ;eae ;
4	am1 anip1 zora1 am1 anip1 zora1	sae ;eae ;%&*()1;
5	una1 aya1	eae ;sae
6	anip1 zora1
7	im1	;;; ;
8
9	aya1	eae ;sae ;eae ;sae sae;;
10	aya1 im1 riP-1	Com
11	im1	Com
Sheet1

Output:

DADPNI.xlsm
	A	B	C	D	E	F	G	H
1		Com	eae					sae
2	am1	4	5					?
3	anip1	1	4					4
4	zora1	2	?					?
5	riP-1	3	?					?
6	una1	3	?					?
7	aya1	3	?					?
8	im1	6	?					?
9	nd#1	1	?					?
Sheet2

Ps. "?" means, I have not counted the number of occurrences here in this demo data.
Data ( more than 10 thousand rows ) in column B is unique (no more repetitions. I have deleted all the duplicate data in column B).
Looking for help from a VBA wizard to solve this.

 

[ZMyrrh]

Public Sub WordCounter()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim n As Integer
Dim sum1 As Long
Dim str1 As String
Dim LookingForWord As String
Dim RequiredWord As String
Dim rounds As Integer
Dim RowsOfData As Long: RowsOfData = 10 'Make this Exactly What You Need.
Dim DataSheetName As String: Let DataSheetName = "Sheet1" 'Make sure this is changed to the sheet where the data is.
Dim ResultSheetName As String: Let ResultSheetName = "Sheet2" ' Make sure this is changed to the sheet where the results should be posted.

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For i = 2 To WorksheetFunction.CountA(Worksheets(ResultSheetName).Range("a1:az1")) + 1
    If Worksheets(ResultSheetName).Cells(1, i).Text <> "" Then
   
    RequiredWord = Worksheets(ResultSheetName).Cells(1, i).Text

    For j = 2 To WorksheetFunction.CountA(Worksheets(ResultSheetName).Range("a1:a100")) + 1
        If Worksheets(ResultSheetName).Cells(j, 1).Text <> "" Then
       
        sum1 = 0
        LookingForWord = Worksheets(ResultSheetName).Cells(j, 1).Text
       
        For k = 2 To RowsOfData
            If Worksheets(DataSheetName).Cells(k, 2).Text <> "" Then
                rounds = 0
               
            For m = 1 To Len(Worksheets(DataSheetName).Cells(k, 2).Text)
                If Mid(Worksheets(DataSheetName).Cells(k, 2).Text, m, Len(RequiredWord)) = RequiredWord Then
                    If rounds = 0 Then
                   
                        rounds = 1
                       
                    For n = 1 To Len(Worksheets(DataSheetName).Cells(k, 1).Text)
                        If Mid(Worksheets(DataSheetName).Cells(k, 1).Text, n, Len(LookingForWord)) = LookingForWord Then
                       
                            sum1 = sum1 + 1
                            Worksheets(ResultSheetName).Cells(j, i).Value = sum1
                           
                        End If
                    Next n
                   
                    End If
                End If
           
            Next m
           
            End If
        Next k
       
        End If
    Next j
   
    End If
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
                   
End Sub

Let me know if this works the way it should. Make sure you change those variables in the VBA so that you get the correct answers.