Here is another VBA macro that should execute relatively quickly, as it does the work in VBA arrays, rather than on the worksheet.
It assumes the source data starts in A1 or A2; the data region is contiguous, and the emails for each company are contiguous (so that the first blank cell in a row is after the last email address). The code would require minor modifications if any of those assumptions are not true.
There is also an assumption that there are no column labels, with instructions in the code comments as to how to compensate for that.
Dim vSrc As Variant
Dim COL As Collection
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim S(0 To 1) As String
Dim I As Long, J As Long
'Define source and result worksheets and ranges
'Alter as necessary
Set wsSrc = Worksheets("sheet3")
Set wsRes = Worksheets("sheet4")
Set rRes = wsRes.Cells(1, 1)
'Read source data into array
' This method assumes data starts in A2, and is
' contained in a contiguous array.
'But other methods could be used
vSrc = wsSrc.Cells(2, 1).CurrentRegion
'Collect the results into Collection object
'Assumes no header row, if there is, then start
' with for I = 2 to ...
Set COL = New Collection
For I = 1 To UBound(vSrc, 1) 'the rows
For J = 2 To UBound(vSrc, 2) 'the columns
S(0) = vSrc(I, 1) 'company name
S(1) = vSrc(I, J) 'email
If S(1) <> "" Then
Exit For 'assumes first blank in email list is end of list
'Create results array
ReDim vres(1 To COL.Count, 1 To 2)
For I = 1 To COL.Count
vres(I, 1) = COL(I)(0)
vres(I, 2) = COL(I)(1)
'Write the results to worksheet
Set rRes = rRes.Resize(rowsize:=UBound(vres, 1), columnsize:=UBound(vres, 2))
.Value = vres