Избегайте использования операторов Select любой ценой и, когда возможно, используйте структуру данных Array для обработки данных.Обработка данных в Arrays намного быстрее, чем чтение / запись с листа.Процедура ниже должна делать то, что вы хотите.Обратите внимание, что хотя и не идеально использовать ReDim Preserve в цикле, я использовал его для количества строк более 100 000 без проблем.Точка, 13000 строк не должно быть проблем.
Sub Transpose()
Dim Data_Array
Dim OutPut_Array()
Dim LR As Long, Counter As Long, LR2 As Long
Dim i As Long
Application.ScreenUpdating = False
'Find the last row of your data in Sheet3 Column A
'I added 1 so that the conditional statement below
'doesn't exclude the last row of data
With Sheets("Sheet3")
LR = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Data_Array = .Range("A1:A" & LR).Value2
End With
'See explanation in the edit section below
On Error Resume Next
For i = LBound(Data_Array, 1) To UBound(Data_Array, 1)
'if the cell is not blank then increase the counter by one
'and for each non blank cell in the Data_Array,
'add it to the OutPut_Array
'If its not blank then output the prepopulated OutPut_Array to Sheet4 and
'set the counter back to zero
If Trim(Data_Array(i, 1)) <> vbNullString Then
Counter = Counter + 1
ReDim Preserve OutPut_Array(1 To 1, 1 To Counter)
OutPut_Array(1, Counter) = Data_Array(i, 1)
Else
With Sheets("Sheet4")
LR2 = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A" & LR2 + 1).Resize(1, Counter).Value2 = OutPut_Array
End With
Counter = 0
End If
Next i
End Sub
Тестовые данные:
Результат:
Это также можно сделать с помощью nested dictionary, однако в этом случае ему потребуется помощь с помощью массивасоздать отношение один ко многим, используя условные операторы, а затем транспонировать словарь, но я все еще пытаюсь усовершенствовать этот метод, поэтому я пошел с вышеизложенным, смеется.Надеюсь, это полезно.
Редактировать: Добавлено On Error Resume Next в соответствии с запросом OP для процедуры, чтобы работать, даже если между строками данных есть более одного пробела.В этом случае On Error Resume Next избегает Run-time error '1004' Application-defined or Object Defined Error, связанного со свойством Range.Resize.Ошибка выдается, когда оператор if просматривает вхождения пустых ячеек, больших 1. В остальной части оператора переменная counter будет равна 0, в результате чего второе измерение диапазона будет равно 0 и выбрасыватьОшибка.Если ячейки в столбце A действительно пустые, как предполагает OP, то это верный способ перехвата ошибки.Также добавлена функция Trim() для обработки пустых ячеек, которые могут иметь пробелы.