|
'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
' Профессиональная разработка приложений для MS Office любой сложности
' Проведение тренингов по MS Excel
' http://www.excel-vba.ru
' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: http://www.excel-vba.ru/chto-umeet-excel/oshibka-too-many-line-continuations/
'---------------------------------------------------------------------------------------
Sub T2Cols()
Const sDelim As String = " " 'разделитель текста
Const lLIMIT_DelimCnt As Long = 100 'максимальное кол-во фрагментов в блоке
Dim aFieldInfo 'массив назначения типов
Dim ws As Worksheet, wsres As Worksheet
Dim asSp, iTmpLen As Long
Dim rTxt As Range, arr, aBreak, aTmp, aFTmp
Dim lDelimCnt As Long, lMaxDelimCnt As Long, lMaxBreaks As Long
Dim lr As Long, lt As Long, lc As Long, lcc As Long
Dim s As String
'берем только первый столбец выделенного текста
Set rTxt = Selection.Columns(1)
'отсекаем ячейки в конце столбца, не содержащие данных
Set rTxt = Intersect(rTxt.Parent.UsedRange, rTxt)
If rTxt Is Nothing Then Exit Sub
Application.ScreenUpdating = 0
arr = rTxt.Value
If Not IsArray(arr) Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rTxt.Value
End If
'определяем максимальное кол-во разделителей во всем диапазоне
For lr = 1 To UBound(arr, 1)
s = arr(lr, 1)
If Len(s) Then
lDelimCnt = Len(s) - Len(Replace(s, sDelim, ""))
If lMaxDelimCnt < lDelimCnt Then
lMaxDelimCnt = lDelimCnt
End If
End If
Next
'максимальное кол-во блоков текста
lMaxBreaks = Application.RoundUp(lMaxDelimCnt / lLIMIT_DelimCnt, 0) + 1
'создаем массив блоков текста для дальнейшего разбиения стандартными средствами
If lMaxDelimCnt > lLIMIT_DelimCnt Then
ReDim aBreak(1 To UBound(arr, 1), 1 To lMaxBreaks)
ReDim aFieldInfo(1 To lMaxBreaks)
For lr = 1 To UBound(arr, 1)
s = arr(lr, 1)
If Len(s) Then
asSp = Split(s, sDelim)
lcc = 0
For lc = 0 To UBound(asSp) Step lLIMIT_DelimCnt
lcc = lcc + 1
If (UBound(asSp) - (lc)) < lLIMIT_DelimCnt Then
iTmpLen = UBound(asSp) - lc
Else
iTmpLen = lLIMIT_DelimCnt - 1
End If
ReDim aTmp(iTmpLen)
ReDim aFTmp(iTmpLen)
For lt = lc To lc + iTmpLen
aTmp(lt - lc) = asSp(lt)
aFTmp(lt - lc) = Array(1, 1) 'Array(1, 2) - если на выходе нужны текстовые значения
Next
aBreak(lr, lcc) = Join(aTmp, sDelim) & sDelim
aFieldInfo(lcc) = aFTmp
Next
End If
Next
Else
MsgBox "Данные можно разбить стандартными средствами: Данные -Текст по столбцам", vbInformation, "www.excel-vba.ru"
Exit Sub
End If
'Создаем лист
Set ws = Worksheets.Add
ws.Name = "tmp"
'записываем на временный лист все разбитые на блоки по 100 столбцы
ws.Cells(1, 1).Resize(UBound(aBreak, 1), UBound(aBreak, 2)).Value = aBreak
'цикл по каждому столбцу, его копирование на результирующий лист и разбиение по разделителю(Пробел - Space:=True)
'если этот цикл не нужен и планируется вручную назначать столбцам параметры
'удалить все, что между чертой ===========
'===============================================================================
Set wsres = Worksheets.Add
wsres.Name = "result"
For lc = 1 To UBound(aBreak, 2)
lcc = wsres.Cells(1, wsres.Columns.Count).End(xlToLeft).Column + 1
aFTmp = aFieldInfo(lc)
ws.Columns(lc).Copy wsres.Cells(1, lcc)
'Эта часть разбивает помещенный на листы текст
wsres.Columns(lcc).TextToColumns Destination:=wsres.Cells(1, lcc), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=aFTmp, TrailingMinusNumbers:=True
Next
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
wsres.Select
'===============================================================================
Application.ScreenUpdating = 1
MsgBox "Данные обработаны", vbInformation, "www.excel-vba.ru"
End Sub | 
