Начинаю новый цикл тем по эффективной реализации на VBA популярных инструментов Excel. Замечания и предложения приветствуются
Процедура + функция
Код
Option Explicit
'===================================================================================================================
Sub ТекстПоСтолбцам()
Dim rng As Range
Dim arr, r&, c&
Static delim$: If Len(delim) = 0 Or delim = "False" Then delim = " "
Set rng = Selection
rep: delim = Application.InputBox("Введите символ-разделитель:", "Запрос данных", delim, Type:=2): If delim = "False" Then Exit Sub
If Len(delim) = 0 Then MsgBox "Вы не ввели символ-разделитель!", vbCritical, "ОШИБКА ВВОДА": GoTo rep
' тут должны быть проверки на корректность диапазона (не пустой, одна область, один столбец и т.д.)
arr = rng.Value2
If Not PRDX_Range_TextToColumns(arr, delim, True) Then Exit Sub
r = rng.Cells(1, 1).Row
c = rng.Cells(1, 1).Column
Application.ScreenUpdating = False
Cells(1, c + 1).Resize(1, UBound(arr, 2)).EntireColumn.Insert
Cells(r, c + 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr
Application.ScreenUpdating = True
End Sub
'===================================================================================================================
Function PRDX_Range_TextToColumns(tmpArr2x, delim$, Optional MsgIfFalse As Boolean) As Boolean ' передать двухмерный массив из одного столбца
Dim x, arrNew(), r&, n&, c&, colMax&
If Not IsArray(tmpArr2x) Then
x = tmpArr2x
ReDim tmpArr2x(1 To 1, 1 To 1)
tmpArr2x(1, 1) = x
x = 0
End If
ReDim arrNew(UBound(tmpArr2x, 1) - 1): colMax = 1
For r = 1 To UBound(tmpArr2x, 1)
If InStr(tmpArr2x(r, 1), delim) Then
x = Split(tmpArr2x(r, 1), delim): arrNew(r - 1) = x
n = UBound(x) + 1: If n > colMax Then colMax = n
Else
arrNew(r - 1) = tmpArr2x(r, 1)
End If
Next r
If colMax = 1 Then
If MsgIfFalse Then MsgBox "Разделитель «" & delim & "» в массиве НЕ НАЙДЕН!", vbExclamation, "PRDX_Range_TextToColumns"
Exit Function
End If
ReDim tmpArr2x(1 To UBound(arrNew) + 1, 1 To colMax)
For r = 1 To UBound(tmpArr2x, 1)
x = arrNew(r - 1)
If IsArray(x) Then
For c = 1 To UBound(x) + 1
tmpArr2x(r, c) = x(c - 1)
Next c
Else
tmpArr2x(r, 1) = x
End If
Next r
PRDX_Range_TextToColumns = True
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄