Мега прога

Форум » Программистские штучки » Мега прога » Ответить

Мега прога

HappyNewYear: До окончательной красивости оформления доводить мне просто лень. Входная переменная-имя книги в которой будет выходной лист, получается из формы, но ещё и формы выкладывать не думаю, что будет интересно. А так... Эх, несколько месяцев моей жизни... [pre2] Sub obnov(gigi As String) 'Очередная мини программа без какого-либо интерфейса. Используется для обновления разбивок в таблице испытаний по Приобке... 'Таблица, в которой будут меняться разбивки, располагается на листе "Лист1", состоит из следующих колонок(в соответствующем порядке) '1 имя скважины, альтитуда, удлинение '2 пласт '3 парные строки глубин/абсолюток залегания пласта (впрочем, в связи с обновлением данные по пластам не несут никакой смысловой нагрузки) '4 парные строки глубин/абсолюток интервалов перфорации '5 дебит нефти '6 дебит воды/обводнённость '7 примечание 'Новые разбивки на листе "Разбивки" (предполагается, что разбивки отсортированы по возрастанию глубин для каждой скважины) '1 well '2 surface '3 Z '4 MD 'Программа осуществляет копирование данных из исходной таблицы в открытый документ(в том же окне, что и "Обновление разбивок_form.xls"), названный в переменной gigi 'Особых косяков, вроде, не обнаружено, единственное, все примечания записываются вподряд, без привязки к дебитам+по дефолту читается одна строка с дебитом, а в разведочных _ всякое бывает... И вообще, на разведочные побольше внимания... 'Шапка копируется до встречи в столбце "А" 1, т.е. строка с номерами столбцов обязательна 'И на последок... Прога адекватно работает только с адекватными исходными данными, т.е. косяки исходных данных остаются на своих местах Dim indexar(1) As String '0 количество строк, 1 имя скважины Dim addpol(2, 10) As Byte '0 Положение дебита, 1 положение комментариев Dim smeshY As Byte 'Строки с шапкой таблицы Dim str(30) As String 'Всякая хрень скопированная из таблицы Dim indSTR As Byte 'Дополнительный индекс Dim all_perf_TB(10, 1) As String 'Все интервалы перфорации, готовые к вставке в таблицу. all_perf_tb(10, 0) количество интервалов на данную скважину Dim allPool(10, 15, 2) As String 'Интервалы пластов на данные интервалы перфорации Dim bbb As Byte 'Счётчики Dim rrr As Byte Dim kkk As Byte Application.ScreenUpdating = False smeshY = 0 Workbooks("Обновление разбивок_form.xls").Activate Sheets("Лист1").Select Range("A1").Select Cells.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder _ :=xlByRows, MatchCase:ъlse, SearchFormat:ъlse, ReplaceFormat:ъlse 'от греха по дальше замена запятых точками. Do smeshY = smeshY + 1 Loop While ActiveCell.Offset(smeshY - 1, 0) <> 1 Rows("1:" & smeshY).Copy 'Workbooks.Add Workbooks(gigi).Activate Sheets("new").Activate ActiveSheet.Paste Application.CutCopyMode = False 'Подавление запроса на очистку буфера обмена Call format_do Range("a" & smeshY + 1).Select Workbooks("Обновление разбивок_form.xls").Activate Sheets("Лист1").Select Range("a" & smeshY + 1).Select Do indSTR = 0 Erase addpol Erase all_perf_TB Erase allPool Call schet_strok(indexar, addpol) If indexar(0) > 29 Then Exit Do Call pr_copy(addpol, str) Call getinterv(indexar, all_perf_TB) If all_perf_TB(10, 0) <> "" Then Call pool(indexar, all_perf_TB, allPool) Workbooks(gigi).Activate Sheets("new").Activate ActiveCell.Offset(0, 0) = str(0) 'Записаны имя скважины ActiveCell.Offset(1, 0) = str(1) '->>- альтитуда ActiveCell.Offset(2, 0) = str(2) '->>- удлинение kkk = 0 If all_perf_TB(10, 0) <> "" Then For bbb = 0 To all_perf_TB(10, 0) ActiveCell.Offset(0 + kkk, 3) = all_perf_TB(bbb, 0) 'глубины перфорации ActiveCell.Offset(0 + kkk + 1, 3) = all_perf_TB(bbb, 1) 'абсолютки перфорации For rrr = 0 To allPool(bbb, 15, 0) ActiveCell.Offset(0 + kkk + rrr * 2, 1) = allPool(bbb, rrr, 2) 'имя пласта ActiveCell.Offset(0 + kkk + rrr * 2, 2) = allPool(bbb, rrr, 0) 'глубины пласта ActiveCell.Offset(0 + kkk + rrr * 2 + 1, 2) = allPool(bbb, rrr, 1) 'абсолютки пласта Next rrr If addpol(2, bbb) = 1 Then 'Если положение дебита и интервала перфорации совпали ActiveCell.Offset(0 + kkk, 4) = str(3 + indSTR * 3) 'Qn ActiveCell.Offset(0 + kkk, 5) = str(4 + indSTR * 3) 'Qw ActiveCell.Offset(1 + kkk, 5) = str(5 + indSTR * 3) 'Обводн indSTR = indSTR + 1 End If kkk = kkk + rrr * 2 Next bbb Else For i = 1 To addpol(0, 0) 'Если нет интервалов перфорации вообще, то пишем дебиты по порядку ActiveCell.Offset(0 + kkk, 4) = str(0 + i * 3) 'Qn ActiveCell.Offset(0 + kkk, 5) = str(1 + i * 3) 'Qw ActiveCell.Offset(1 + kkk, 5) = str(2 + i * 3) 'Обводн kkk = kkk + 2 Next i End If For bbb = 1 To addpol(1, 0) 'Запись примечаний, тупо по порядку ActiveCell.Offset(bbb - 1, 6) = str(2 + bbb + addpol(0, 0) * 3) Next bbb If kkk < 3 Then kkk = 3 'Количество строк на скважину в новой таблице Call format_table(kkk) ActiveCell.Offset(kkk, 0).Select Workbooks("Обновление разбивок_form.xls").Activate Sheets("Лист1").Select ActiveCell.Offset(indexar(0), 0).Select Loop While indexar(0) <> "Пока рак на горе не свиснет!" 'гы, условие никогда не выполнится, да и не надо, прерывание внутри цикла Workbooks(gigi).Save Application.ScreenUpdating = True End Sub Sub schet_strok(ByRef indexar() As String, ByRef addpol() As Byte) 'Эх, руки бы оборвать этому программисту, _ Но у нас с покон веков _ Нет суда на дураков... Dim well As String 'Переменная в которую считываются поля из столбца с номерами скважин Dim strWell As Integer 'Число строк на скважину Dim kui As Byte 'Счётчик, используется для посимвольного чтения номера скважин Dim wellNumber As Integer 'Номер скважины, если повезёт... Dim t As Byte 'Числовой код первого\последнего символа в переменной well Dim proVer_na_text As Boolean 'проверка на наличие текста в названии скважины Dim tekSTR As Integer 'Текущее положение номера скважины Dim numINT As Byte 'Номер интервала перфорации Dim hj As Byte 'ReDim indexar(1) 'ReDim addpol(0,10) lll = 0 addpol(0, 0) = 0 addpol(1, 0) = 0 tekSTR = -1 strWell = -1 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Модуль для счёта строк на скважину'''''''''''''''''''''''''''''''''''''''''''''''''' Do kui = 1 wellNumber = 0 strWell = strWell + 1 well = ActiveCell.Offset(strWell, 0) If strWell - tekSTR > 30 Then indexar(0) = 20: Exit Do 'Выход по постижении конца таблицы+пометка для завершения глобального цикла If ActiveCell.Offset(strWell, 4) <> "" Then addpol(0, 0) = addpol(0, 0) + 1 addpol(0, addpol(0, 0)) = strWell End If If ActiveCell.Offset(strWell, 6) <> "" Then addpol(1, 0) = addpol(1, 0) + 1 addpol(1, addpol(1, 0)) = strWell End If If ActiveCell.Offset(strWell, 3) <> "" Then numINT = numINT + 1 If ActiveCell.Offset(strWell, 3) <> "" And ActiveCell.Offset(strWell, 4) <> "" Then addpol(2, (numINT - 1) / 2) = 1 If well <> "" Then t = Asc(Left(well, 1)) If (t > 64 And t < 91) Or (t > 96 And t < 123) Or (t > 191 And t <= 255) Then Exit Do 'проверка на текст в начале поля скв. Do While kui <= Len(well) If (Asc(Mid(well, kui, 1)) < 48 Or Asc(Mid(well, kui, 1)) > 57) Then Exit Do 'Чтение номера скважины, который заведомо больше wellNumber = wellNumber & Mid(well, kui, 1) 'альтитуды и удлинения kui = kui + 1 Loop End If Loop While wellNumber < 10000 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' indexar(1) = well If wellNumber > 10000 Then indexar(1) = wellNumber If Len(well) > 5 Then If wellNumber > 10000 And Asc(Mid(well, 6, 1)) <> 98 Then indexar(1) = wellNumber If wellNumber > 10000 And Asc(Mid(well, 6, 1)) = 98 Then indexar(1) = Left(well, 6) End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Модуль для счёта строк на скважину'''''''''''''''''''''''''''''''''''''''''''''''''' Do kui = 1 wellNumber = 0 strWell = strWell + 1 well = ActiveCell.Offset(strWell, 0) If strWell - tekSTR > 30 Then indexar(0) = 20: Exit Do 'Выход по постижении конца таблицы+пометка для завершения глобального цикла If well <> "" Then t = Asc(Left(well, 1)) If (t > 64 And t < 91) Or (t > 96 And t < 123) Or (t > 191 And t <= 255) Then Exit Do 'проверка на текст в начале поля скв. Do While kui <= Len(well) If (Asc(Mid(well, kui, 1)) < 48 Or Asc(Mid(well, kui, 1)) > 57) Then Exit Do 'Чтение номера скважины, который заведомо больше wellNumber = wellNumber & Mid(well, kui, 1) 'альтитуды и удлинения kui = kui + 1 Loop End If If ActiveCell.Offset(strWell, 4) <> "" And wellNumber < 10000 Then addpol(0, 0) = addpol(0, 0) + 1 addpol(0, addpol(0, 0)) = strWell End If If ActiveCell.Offset(strWell, 6) <> "" And wellNumber < 10000 Then addpol(1, 0) = addpol(1, 0) + 1 addpol(1, addpol(1, 0)) = strWell End If If ActiveCell.Offset(strWell, 3) <> "" Then numINT = numINT + 1 If ActiveCell.Offset(strWell, 3) <> "" And ActiveCell.Offset(strWell, 4) <> "" And wellNumber < 10000 Then addpol(2, (numINT - 1) / 2) = 1 Loop While wellNumber < 10000 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' indexar(0) = strWell End Sub Sub temp() Workbooks.Add ActiveSheet.Paste Application.CutCopyMode = False 'Подавление запроса на очистку буфера обмена gigi = "Таблица испытаний с разбивками на " & Date & ".xls" ActiveWorkbook.SaveAs Filename:= _ gigi, FileFormat _ :=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _ False, CreateBackup:ъlse 'Сохранение новой книги с именем текущей даты End Sub Sub pr_copy(addpol, ByRef str() As String) Dim i As Byte 'Тупо счётчик str(0) = ActiveCell.Offset(0, 0) str(1) = ActiveCell.Offset(1, 0) str(2) = ActiveCell.Offset(2, 0) For i = 1 To addpol(0, 0) str(0 + i * 3) = ActiveCell.Offset(addpol(0, i), 4) str(1 + i * 3) = ActiveCell.Offset(addpol(0, i), 5) str(2 + i * 3) = ActiveCell.Offset(addpol(0, i) + 1, 5) m = m + 1 Next i For i = 1 To addpol(1, 0) str(2 + i + addpol(0, 0) * 3) = ActiveCell.Offset(addpol(1, i), 6) Next i End Sub Sub getinterv(indexar, ByRef all_perf_TB() As String) 'Модуль сичтывает ВСЕ интервалы перфорации на данную скважину. 'Входной аргумент должен содержать количество строк, приходящихся на данную скважину 'Выходной пердставляет собой двумерный массив, где первый индекс - номер интервала, второй 0-глубины,1абсолютки. Все интервалы перфорации в текстовом формате. 'all_perf_tb(10, 0) количество интервалов на данную скважину Dim numstr As Byte 'Номер строки относительно ячейки с номером скважины Dim numINTperf As Byte 'Номер интервала перфорации 'Dim dbl_TB(1) As Double 'кровля/подошва в глубинах Dim str_TB(1) As String 'Глубины/абсолютки перфорации 'Dim all_perf_tb(10, 1) As String 'Все интервалы перфорации, готовые к вставке в таблицу numINTperf = 0 For numstr = 0 To indexar(0) - 1 If ActiveCell.Offset(numstr, 3) <> "" Then 'Erase dbl_TB(1) Erase str_TB Call interv(numstr, str_TB) numstr = numstr + 1 all_perf_TB(numINTperf, 0) = str_TB(0) all_perf_TB(numINTperf, 1) = str_TB(1) numINTperf = numINTperf + 1 End If Next numstr If numINTperf > 1 Then all_perf_TB(10, 0) = numINTperf - 1 ElseIf numINTperf = 1 Then all_perf_TB(10, 0) = "0" Else: all_perf_TB(10, 0) = "" End If End Sub Sub interv(numstr, str_topBOT() As String) 'Данный модуль считывает значение кровли/подошвы интервала перфорации. 'Входной аргумент - положение ячейки с глубиной интервала перфорации относительно ячейки с текущим номером скважины. 'Выходные аргументы: _ str_topBOT()-0 форматированный интервал перфорации в глубинах, 1 ->>- в абсолютках 'ByRef dbl_topBOT() As Double, 'dbl_topBOT()-0 кровля, 1 подошва интервала перфорации в глубинах _ была такая вот мысля, но что-то отказался... Dim kg_am As Byte 'текущее положение чтения символа 'Dim dbl_topBOT(1) As Double '0 кровля, 1 подошва Dim tmpTB As String Dim dlin_str As Byte 'Длина строковой переменной Dim ttt As Byte 'Dim str_topBOT(1) As String tmpTB = "" For ttt = 0 To 1 dlin_str = Len(ActiveCell.Offset(numstr + ttt, 3)) If dlin_str > 0 Then kg_am = 1 Do While (Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) > 47 And Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) < 58) _ Or Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) = 44 _ Or Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) = 46 tmpTB = tmpTB & Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1) kg_am = kg_am + 1 If kg_am > dlin_str Then Exit Do Loop If kg_am = 7 Then str_topBOT(ttt) = tmpTB ElseIf kg_am = 5 Then str_topBOT(ttt) = tmpTB & ".0" ElseIf kg_am > 7 Then str_topBOT(ttt) = Left(tmpTB, 6) ElseIf kg_am = 6 Then str_topBOT(ttt) = tmpTB & "0" Else str_topBOT(ttt) = "Косяк!" End If 'If ttt < 1 Then dbl_topBOT(0) = CDbl(tmpTB) 'Кровля tmpTB = "" Do Until Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) > 47 And Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) < 58 kg_am = kg_am + 1 If kg_am > dlin_str Then GoTo 1 Loop Do While (Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) > 47 And Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) < 58) _ Or Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) = 44 _ Or Asc(Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1)) = 46 tmpTB = tmpTB & Mid(ActiveCell.Offset(numstr + ttt, 3), kg_am, 1) kg_am = kg_am + 1 If kg_am > dlin_str Then Exit Do Loop 1 kg_am = Len(tmpTB) + 1 'Не судите строго люди, но так надо для удобства... Тут кг_ам уже не положение символа, а дляна переменной tmpTB If kg_am = 7 Then str_topBOT(ttt) = str_topBOT(ttt) & "-" & tmpTB ElseIf kg_am = 5 Then str_topBOT(ttt) = str_topBOT(ttt) & "-" & tmpTB & ".0" ElseIf kg_am > 7 Then str_topBOT(ttt) = str_topBOT(ttt) & "-" & Left(tmpTB, 6) ElseIf kg_am = 6 Then str_topBOT(ttt) = str_topBOT(ttt) & "-" & tmpTB & "0" Else str_topBOT(ttt) = str_topBOT(ttt) & "-" & "Косяк!" End If 'If ttt < 1 Then dbl_topBOT(1) = CDbl(tmpTB) 'Подошва tmpTB = "" End If Next ttt End Sub Sub pool(indexar, all_perf_TB, ByRef allPool) Dim ggg As Byte 'Счётчик Dim smeshY As Byte 'Смещение при поиске интервала пласта на листе с разбивками Dim indPOOL As Byte 'Индекс в pool Dim tmp As Boolean On Error Resume Next Sheets("Разбивки").Select 'Поиск скважины на листе с разбивками For ggg = 0 To all_perf_TB(10, 0) If Left(all_perf_TB(ggg, 0), 6) <> "Косяк!" And Right(all_perf_TB(ggg, 0), 6) <> "Косяк!" Then Range("a1").Select Cells.Find(What:=indexar(1), After:¬tiveCell, LookIn:=xlFormulas, LookAt _ :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ False, SearchFormat:ъlse).Activate 'Найдена Скважина If CStr(ActiveCell.Offset(0, 0)) Like indexar(1) Then smeshY = 0 'Обнуление смещения относительно первоначально встретившийся ячейки с номером скважины Do While ActiveCell.Offset(smeshY, 3) - Left(all_perf_TB(ggg, 0), 6) < 2 And CStr(ActiveCell.Offset(smeshY, 0)) Like indexar(1) 'Цикл в поисках кровли пласта, который проперфорирован smeshY = smeshY + 1 Loop indPOOL = 0 Do allPool(ggg, indPOOL, 2) = ActiveCell.Offset(smeshY - 1, 1) 'Записано имя пласта allPool(ggg, indPOOL, 0) = ActiveCell.Offset(smeshY - 1, 3) '->>- кровля(MD) If Len(ActiveCell.Offset(smeshY - 1, 3)) = 4 Then allPool(ggg, indPOOL, 0) = allPool(ggg, indPOOL, 0) & ".0" 'Наведение красоты If CStr(ActiveCell.Offset(smeshY, 0)) Like indexar(1) Then 'Проверка, чтоб не выскочить ниже проинтерпретированных интервалов allPool(ggg, indPOOL, 0) = allPool(ggg, indPOOL, 0) & -ActiveCell.Offset(smeshY, 3) 'Подошва (MD) If Len(ActiveCell.Offset(smeshY, 3)) = 4 Then allPool(ggg, indPOOL, 0) = allPool(ggg, indPOOL, 0) & ".0" 'Наведение красоты Else: allPool(ggg, indPOOL, 0) = allPool(ggg, indPOOL, 0) & "-н.д." 'Если проперфорировано ниже интерпретации, то "нет данных", т.е. "н.д." End If allPool(ggg, indPOOL, 1) = -ActiveCell.Offset(smeshY - 1, 2) 'Блок полностью аналогичен, представленному выше, только здесь пишутся абсолютки If Len(ActiveCell.Offset(smeshY - 1, 2)) = 5 Then allPool(ggg, indPOOL, 1) = allPool(ggg, indPOOL, 1) & ".0" If CStr(ActiveCell.Offset(smeshY, 0)) Like indexar(1) Then allPool(ggg, indPOOL, 1) = allPool(ggg, indPOOL, 1) & ActiveCell.Offset(smeshY, 2) If Len(ActiveCell.Offset(smeshY, 2)) = 5 Then allPool(ggg, indPOOL, 1) = allPool(ggg, indPOOL, 1) & ".0" Else: allPool(ggg, indPOOL, 1) = allPool(ggg, indPOOL, 1) & "-н.д." End If smeshY = smeshY + 1 'Перешли к следующему пласту indPOOL = indPOOL + 1 'Прибавили индекс Loop While ActiveCell.Offset(smeshY - 1, 3) - Right(all_perf_TB(ggg, 0), 6) < 1 And CStr(ActiveCell.Offset(smeshY - 1, 0)) Like indexar(1) 'Цикл продолжается до тех пор, пока подошва последнего пласта выше подошвы интервала перфорации, и совпадают номера скважин End If End If If indPOOL > 0 Then allPool(ggg, 15, 0) = indPOOL - 1 Else: allPool(ggg, 15, 0) = 0 End If Next ggg End Sub Sub format_table(kkk) Dim Xsmesh As Byte 'Счётчик для For Dim Ysmesh As Byte 'Счётчик для For '''''''''''''''''''''''''''''''''Толстая верхняя граница+центровка''''''''''''''''''''''''''''''''''''''''''''''''''''' For Xsmesh = 0 To 7 For Ysme ... [/pre2]

Ответов - 1

HappyNewYear: [pre2] ... sh = 0 To kkk - 1 'With ActiveCell.Offset(Ysmesh, Xsmesh).Borders(xlEdgeLeft) ' .LineStyle = xlContinuous ' .ColorIndex = 0 ' .TintAndShade = 0 ' .Weight = xlMedium 'End With If (Ysmesh = 0 And Xsmesh <> 7) Or (ActiveCell.Offset(Ysmesh, 4) <> "" And Xsmesh > 0 And Xsmesh < 6) And (Ysmesh Mod 2) = 0 Then With ActiveCell.Offset(Ysmesh, Xsmesh).Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With End If If Xsmesh = 7 And Ysmesh = kkk - 1 Then Exit For 'With ActiveCell.Offset(Ysmesh, Xsmesh) ' .HorizontalAlignment = xlCenter ' .VerticalAlignment = xlCenter ' .WrapText = True ' .Orientation = 0 ' .AddIndent = False ' .IndentLevel = 0 ' .ShrinkToFit = False ' .ReadingOrder = xlContext ' .MergeCells = False 'End With Next Ysmesh Next Xsmesh ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Selection.NumberFormat = "@" ActiveCell.Offset(1, 0).NumberFormat = "0.0" ActiveCell.Offset(2, 0).NumberFormat = "0.0" ActiveCell.Offset(0, 1).NumberFormat = "@" '''''''''''''''''''''''''''''''''''''''Подчёркивания'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' For Xsmesh = 2 To 3 For Ysmesh = 0 To kkk - 1 ActiveCell.Offset(Ysmesh, Xsmesh).NumberFormat = "@" ActiveCell.Offset(Ysmesh, Xsmesh).Font.Underline = xlUnderlineStyleNone If Ysmesh Mod 2 = 0 Then ActiveCell.Offset(Ysmesh, Xsmesh).Font.Underline = xlUnderlineStyleSingle Next Ysmesh Next Xsmesh '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''Дебиты'''''''''''''''''' For Ysmesh = 0 To kkk Step 2 ActiveCell.Offset(Ysmesh, 4).NumberFormat = "0.00" ActiveCell.Offset(Ysmesh, 5).NumberFormat = "0.00" ActiveCell.Offset(Ysmesh + 1, 5).NumberFormat = "0.00%" Next Ysmesh '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' End Sub Sub format_do() Columns("A:a").Select Selection.ColumnWidth = 11 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Columns("b:b").Select Selection.ColumnWidth = 10 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Columns("C:c").Select Selection.ColumnWidth = 15 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Columns("D:d").Select Selection.ColumnWidth = 15 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Columns("E:e").Select Selection.ColumnWidth = 10 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Columns("f:F").Select Selection.ColumnWidth = 10 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Columns("G:G").Select Selection.ColumnWidth = 12 With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Columns("h:h").Select With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With Columns("a:G").Select With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End Sub [/pre2]

полная версия страницы