Доброго утра, уважаемые форумчане! У меня есть тема () - по названию практически такая же (для тех, кто ищет). Там всё глухо и, если я буду там писать просто так, то, по сути, это UP и это плохо...
Здесь же прошу вашей помощи по оптимизации самого подходящего (для моих задач) макроса - WrapDownWithLeftColomn: он сцепляет выделенный диапазон (который нужно разнести по строкам) со столбцом слева, переносит целевой и расцепляет обратно - в итоге построчная связь не разрушается и остальные поля можно подтянуть через ВПР по СТОЛБЦУ СЛЕВА (с цифрами). Долго, нудно, но работает...
В примере 20 позиций (секунд 30 обрабатывает), в оригинале около 300 (и это далеко не предел) - excel виснет безбожно((((
P.S.: замечено, что время работы меняется НЕ прямо пропорционально объёму, а чуть ли не в геометрической прогрессии, то есть увеличение объёма в 4 раза увеличивает время работы макроса почти в 16!!! раз
Здесь же прошу вашей помощи по оптимизации самого подходящего (для моих задач) макроса - WrapDownWithLeftColomn: он сцепляет выделенный диапазон (который нужно разнести по строкам) со столбцом слева, переносит целевой и расцепляет обратно - в итоге построчная связь не разрушается и остальные поля можно подтянуть через ВПР по СТОЛБЦУ СЛЕВА (с цифрами). Долго, нудно, но работает...
В примере 20 позиций (секунд 30 обрабатывает), в оригинале около 300 (и это далеко не предел) - excel виснет безбожно((((
P.S.: замечено, что время работы меняется НЕ прямо пропорционально объёму, а чуть ли не в геометрической прогрессии, то есть увеличение объёма в 4 раза увеличивает время работы макроса почти в 16!!! раз
| Код |
|---|
'Перенос текста в выделенном диапазоне на СТРОКИ НИЖЕ при заполнении столбца по ширине 'Принцип: содержимое ячейки, которое переносится "визуально" при изменении ширины столбца, макрос переносит на самом деле в нижние ячейки 'Особенность: сцепляет переносимое с содержимым солбца слева, после переноса расцепляет обратно для соблюдения связи 'Переменная "myEC" - вспомогательный столбец (будет очищен после выполнения макроса) '======================================================================================================= Sub WrapDownWithLeftColomn() Dim c As Range, myRa As Range Dim s As String Dim Arr As Variant Dim i As Integer Dim d As Variant Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ActiveSheet.DisplayPageBreaks = False Application.DisplayStatusBar = False Application.DisplayAlerts = False Set myRa = Selection myC = myRa.Column myE = myRa.Row - 1 myR = myRa.Row myEC = 10 '№ вспомогательного столбца Columns(myEC).EntireColumn.Clear For Each r In myRa.Rows myE = myE + 1 d = Cells(r.Row, myC).ColumnWidth * 1.05 'ширина первоначальной ячейки (несколько увеличена) Arr = Split(Cells(r.Row, myC), " ") s = "" Cells(myE, myEC - 1) = Cells(r.Row, myC - 1) For i = 0 To UBound(Arr) s = s & Arr(i) & " " Cells(myE, myEC) = s Cells(myE, myEC).EntireColumn.AutoFit If Cells(myE, myEC).ColumnWidth > d Then Cells(myE, myEC).ColumnWidth = d Cells(myE, myEC).Value = left(s, Len(s) - (Len(Arr(i)) + 1)) 'без последнего слова i = i - 1 'т.к. слово выкинули '---- переход в другую ячейку ---- myE = myE + 1 s = "" End If Next i Next myRa.Delete Shift:=xlUp Range(Cells(myR, myC - 1), Cells(myE, myC - 1)).Delete Shift:=xlUp Range(Cells(myR, myEC - 1), Cells(myE, myEC)).Copy Cells(myR, myC - 1).Insert Shift:=xlDown Range(Cells(myR, myEC - 1), Cells(myE, myEC)).Clear Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayStatusBar = True Application.DisplayAlerts = True End Sub '========================================================================================================= Sub WrapDown() Dim c As Range, myRa As Range Dim s As String Dim Arr As Variant Dim i As Integer Dim d As Variant Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ActiveSheet.DisplayPageBreaks = False Application.DisplayStatusBar = False Application.DisplayAlerts = False Set myRa = Selection myC = myRa.Column myE = myRa.Row - 1 myR = myRa.Row myEC = myC + 5 '№ вспомогательного столбца Columns(myEC).EntireColumn.Clear For Each r In myRa.Rows myE = myE + 1 d = Cells(r.Row, myC).ColumnWidth * 1.05 'ширина первоначальной ячейки (несколько увеличена) Arr = Split(Cells(r.Row, myC), " ") s = "" For i = 0 To UBound(Arr) s = s & Arr(i) & " " Cells(myE, myEC) = s Cells(myE, myEC).EntireColumn.AutoFit If Cells(myE, myEC).ColumnWidth > d Then Cells(myE, myEC).ColumnWidth = d Cells(myE, myEC).Value = left(s, Len(s) - (Len(Arr(i)) + 1)) 'без последнего слова i = i - 1 'т.к. слово выкинули '---- переход в другую ячейку ---- myE = myE + 1 s = "" End If Next i Next myRa.Delete Shift:=xlUp Range(Cells(myR, myEC), Cells(myE, myEC)).Copy Cells(myR, myC).Insert Shift:=xlDown Columns(myEC).EntireColumn.Clear Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayStatusBar = True Application.DisplayAlerts = True End Sub |
Изменено: - 04.05.2016 10:43:03
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Но благодаря откликнувшимся в теме возникшей в поисках решения по этой теме, вопрос разрешился, за что я им всем благодарен. 