Aqui está outra macro do VBA que deve ser executada com relativa rapidez, como acontece no trabalho em arrays VBA, e não na planilha.
Assume que os dados de origem começam em A1 ou A2; a região de dados é contígua e os emails de cada empresa são contíguos (de forma que a primeira célula em branco em uma linha seja após o último endereço de email). O código exigiria pequenas modificações se qualquer uma dessas suposições não for verdadeira.
Há também uma suposição de que não há rótulos de coluna, com instruções nos comentários do código sobre como compensar isso.
Option Explicit
Sub RowsToColumns()
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
COL.Add S
Else
Exit For 'assumes first blank in email list is end of list
End If
Next J
Next I
'Create results array
ReDim vres(1 To COL.Count, 1 To 2)
For I = 1 To COL.Count
With COL(I)
vres(I, 1) = COL(I)(0)
vres(I, 2) = COL(I)(1)
End With
Next I
'Write the results to worksheet
Set rRes = rRes.Resize(rowsize:=UBound(vres, 1), columnsize:=UBound(vres, 2))
With rRes
.EntireColumn.Clear
.Value = vres
.EntireColumn.AutoFit
End With
End Sub