Вот еще один макрос VBA, который должен выполняться относительно быстро, поскольку он выполняет работу в массивах VBA, а не на листе.
Предполагается, что исходные данные начинаются с A1 или A2; область данных является непрерывной, а электронные письма для каждой компании являются смежными (так что первая пустая ячейка в строке находится после последнего адреса электронной почты). Код потребует незначительных изменений, если любое из этих предположений не соответствует действительности.
Существует также предположение, что в комментариях к коду отсутствуют метки столбцов с инструкциями о том, как это компенсировать.
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