Добрый день, спасибо за ответы. А как посмотреть диспетчер имен в рабочей книге? Ниже весь макрос:
Option Explicit
Const ER = 16000
Public MainResult As Range Public detailRESULT As Range Public AreaForSearch As Range Public BE_Arr() As Variant 'Public fso As Variant, ts As Variant Public rRang As Range Public CR_ As String
Sub SAPBEXonRefresh(queryID As String, resultArea As Range) Dim IDf4 As String, svodID As String, detailID As String Dim kol_be As Long, iNum As Long 'Dim vFileName As String Dim i As Long Dim Prn As String
With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .Calculation = xlCalculationAutomatic End With
' CR_ = Chr(13) & Chr(10) ' Set fso = CreateObject("Scripting.FileSystemobject") ' vFileName = "C:\1\" & queryID & ".prt" ' Set ts = fso.CreateTextFile(vFileName, True) ' ts.Write "Протокол формирования отчета" & CR_ ' ts.Write "Начало формирования: " & Date & " " & Time & CR_ & CR_
IDf4 = SAPBEXqueries.Range("F4:F4").Value 'Worksheets("Print").Range("A1:A1").Value = queryID 'Worksheets("Print").Range("A2:A2").Value = IDf4
For i = 1 To 20 ' ID запросов, которые использовались до перехода на мультиотчёты (Комментарий от Пятова Михаила 13.03.2012) If SAPBEXqueries.Range("C" + Trim(Str(i)) + ":C" + Trim(Str(i))).Value = "4HJMIDCTM689GFB0IRP6DDKWY" Then svodID = SAPBEXqueries.Range("F" + Trim(Str(i)) + ":F" + Trim(Str(i))).Value End If If SAPBEXqueries.Range("C" + Trim(Str(i)) + ":C" + Trim(Str(i))).Value = "4HJMIWCGHPWCI5DYY3HJ88EN6" Then detailID = SAPBEXqueries.Range("F" + Trim(Str(i)) + ":F" + Trim(Str(i))).Value End If
' Вставка 13.03.2012 Пятов Михаил
' Для корректной отработки макроса для разных иерархий необходимо учитывать, ' что ID запросов изменились, поиск выше результатов не давал, поэтому листы по филиалам (например: ГО, УР и тп) ' не заполнялись значениями с листа Detail. Нужно это учитывать. ' Технические ID запросов, включённых в раб.книгу можно найти на листе SAPBEXqueries, в свойстах сделав его видимым ' (Комментарий от Пятова Михаила 13.03.2012)
If SAPBEXqueries.Range("C" + Trim(Str(i)) + ":C" + Trim(Str(i))).Value = "4LF1NXZADTT7ZR8Z8LUQZCXLU" Then svodID = SAPBEXqueries.Range("F" + Trim(Str(i)) + ":F" + Trim(Str(i))).Value End If If SAPBEXqueries.Range("C" + Trim(Str(i)) + ":C" + Trim(Str(i))).Value = "4LF1NZWF4H8LNE40P4FTHUM1U" Then detailID = SAPBEXqueries.Range("F" + Trim(Str(i)) + ":F" + Trim(Str(i))).Value End If ' Конец вставки от 13.03.2012
' Вставка 27.11.2012 If SAPBEXqueries.Range("C" + Trim(Str(i)) + ":C" + Trim(Str(i))).Value = "007VOYF1MNZVW8WIV948EML1C" Then svodID = SAPBEXqueries.Range("F" + Trim(Str(i)) + ":F" + Trim(Str(i))).Value End If If SAPBEXqueries.Range("C" + Trim(Str(i)) + ":C" + Trim(Str(i))).Value = "007VOYF1MNZXMJARA0IGYAKG6" Then detailID = SAPBEXqueries.Range("F" + Trim(Str(i)) + ":F" + Trim(Str(i))).Value End If Next
If queryID = svodID Then ' Вставка от 13.03.2012 Запись рассчитанного значения Области результатов в ячейку А6 листа Настройка ' Worksheets("Настройка").Range("a1").Value = resultArea.Address Setup.Range("A6").Value = resultArea.Address ' Конец вставки от 13.03.2012 Пятов М. 'Set MainResult = resultArea End If
If queryID = detailID Then ' Вставка от 13.03.2012 Запись рассчитанного значения Области результатов в ячейку А7 листа Настройка 'Worksheets("Настройка").Range("a2").Value = resultArea.Address Setup.Range("A7").Value = resultArea.Address ' Конец вставки от 13.03.2012 Пятов М. 'Set detailRESULT = resultArea End If
'MsgBox resultArea.Address
' Вставка от 17.05.2012 НР ' Заполнение массива БЕ iNum = 1 kol_be = 0 Do While Setup.Cells(iNum, 14).Value <> "" kol_be = kol_be + 1 ReDim Preserve BE_Arr(1 To 4, 1 To kol_be) As Variant BE_Arr(1, kol_be) = Setup.Cells(iNum, 14).Value BE_Arr(2, kol_be) = Setup.Cells(iNum, 15).Value BE_Arr(3, kol_be) = Setup.Cells(iNum, 16).Value BE_Arr(4, kol_be) = Setup.Cells(iNum, 17).Value iNum = iNum + 1 Loop ' Окончание вставки от 17.05.2012 НР
If queryID = IDf4 Then Prn = "2" Sheets(Prn).Select Call GlobalFormattingVer01 ' Call Clear("Main", 17) Call Del_Col("Main", 5) Call Clear("Detail", 17) End If
' ts.Write "Окончание формирования: " & Date & " " & Time ' ts.Close ' Set ts = Nothing ' Set fso = Nothing
With Application .ScreenUpdating = True .EnableEvents = True .DisplayAlerts = True End With End Sub
Sub GlobalFormattingVer01() Dim i As Long, k As Long, iFound As Long, iNum As Long, iCount As Long Dim BE_Name As String Dim wShape As Shape Dim wSheet As Worksheet Dim lLastRow As Long, lLastCol As Long Dim MainAddress As String, DetailAddress As String Dim NODataAREArows As Long, RowCnt As Long Dim Sourse As String, BECell As String Dim yOffset As Long, x1 As Long, y1 As Long, x1svod As Long Dim StrADDRess As String Dim vRange As Variant
' ts.Write "GlobalFormattingVer01: " & Date & " " & Time & CR_ & CR_
'Application.ScreenUpdating = False
' Вставка 13.03.2012 Пятов Михаил ' Считывание значений диапазонов областей результатов из вставленных в лист Настройки значений A6 и A7
' MainAddress = Worksheets("Настройка").Range("a1").Value ' DetailAddress = Worksheets("Настройка").Range("a2").Value MainAddress = Setup.Range("A6").Value DetailAddress = Setup.Range("A7").Value ' Окончание вставки от 13.03.2012 Пятов М.
Worksheets("Main").Activate Set MainResult = Worksheets("Main").Range(MainAddress) Worksheets("Detail").Activate Set detailRESULT = Worksheets("Detail").Range(DetailAddress) NODataAREArows = 2 RowCnt = MainResult.Rows.Count - NODataAREArows Sourse = "Detail" yOffset = 5 y1 = detailRESULT.Columns.Count + detailRESULT.Column - 1 x1 = detailRESULT.Row + NODataAREArows x1svod = MainResult.Row + NODataAREArows Worksheets(Sourse).Activate BECell = Worksheets(Sourse).Cells(x1, 1).Value
'Clear all target sheets ' Закомментарил 17.05.2012 НР 'Clear "УР" 'Clear "АТ" 'Clear "АК" 'Clear "КОС" 'Clear "ЮЖ" 'Clear "ШЫМ" 'Clear "АГП ШЫМ" 'Clear "АГП" 'Clear "УП" 'Clear "КО" 'Clear "АКТАУ" 'Clear "ТАРАЗ" 'Clear "УКК" 'Clear "АГП ТАРАЗ" 'Clear "УАВРиСТ" 'Clear "АГП УАВРиСТ" 'Clear "ББШ Актобе" 'Clear "ББШ Южный" 'Clear "ББШ Кызылорда" 'Clear "ББШ Актау" 'Clear "ББШ УАВРиСТ" 'Clear "ББШ Костанай" 'Clear "ББШ Шымкент"
' Окончание закомментаренного куска от 17.05.2012 НР Call Clear("2", 14) Call Clear("Свод", 14) ' Вставка от 17.05.2012 НР Call Clear("ГО", 14) ' Application.DisplayAlerts = False With ActiveWorkbook iCount = .Sheets.Count i = 1 Do While i <= iCount iFound = 0 For k = LBound(BE_Arr, 2) To UBound(BE_Arr, 2) If Sheets.Item(i).Name = BE_Arr(2, k) And BE_Arr(3, k) = 0 Then iFound = k Exit For End If Next k If iFound > 0 Then Sheets(i).Select ActiveWindow.SelectedSheets.Delete iCount = .Sheets.Count Else i = i + 1 End If Loop End With ' Application.DisplayAlerts = True iNum = 0 With ActiveWorkbook For i = 1 To .Sheets.Count If Sheets.Item(i).Name = "ГО" Then iNum = i Exit For End If Next i End With
For k = UBound(BE_Arr, 2) To LBound(BE_Arr, 2) Step -1 If BE_Arr(3, k) = 0 Then Sheets("ГО").Select Sheets("ГО").Copy After:=Sheets("ГО") Sheets(iNum + 1).Name = BE_Arr(2, k) Sheets(iNum + 1).Cells(8, 1).Value = "Балансовая единица: " & BE_Arr(4, k) Else Sheets(iNum).Cells(8, 1).Value = "Балансовая единица: " & BE_Arr(4, k) End If Next k ' Окончание вставки от 17.05.2012 НР
Worksheets("Main").Activate StrADDRess = Worksheets("Main").Range(Cells(x1svod, 5), Cells(x1svod + RowCnt - 1, 31)).Address CopyValue StrADDRess, "2", "Main", "G14" Worksheets("Main").Activate StrADDRess = Worksheets("Main").Range(Cells(x1svod, 5), Cells(x1svod + RowCnt - 1, 11)).Address CopyValue StrADDRess, "Свод", "Main", "G14" Worksheets("Main").Activate StrADDRess = Worksheets("Main").Range(Cells(x1svod, 32), Cells(x1svod + RowCnt - 1, UBound(BE_Arr, 2) + 36)).Address CopyValue StrADDRess, "Свод", "Main", "N14" Worksheets("Main").Activate StrADDRess = Worksheets("Main").Range(Cells(x1svod, 28), Cells(x1svod + RowCnt - 1, 31)).Address CopyValue StrADDRess, "Свод", "Main", ColumnAddress(14 + UBound(BE_Arr, 2)) & "14" Main ("СВод")
For Each wSheet In Worksheets ' Удаление треугольных рисунков For Each wShape In wSheet.Shapes wShape.Delete Next If wSheet.Name = "2" Or wSheet.Name = "Свод" Or wSheet.Name = "Detail" Then wSheet.Activate lLastRow = Cells.SpecialCells(xlLastCell).Row lLastCol = Cells.SpecialCells(xlLastCell).Column If wSheet.Name = "2" Or wSheet.Name = "Свод" Then If lLastRow >= 14 Then Range(Cells(14, 1), Cells(lLastRow, lLastCol)).Select 'цвет белый Selection.Interior.ColorIndex = xlNone If lLastCol >= 7 Then Range(Cells(14, 7), Cells(lLastRow, lLastCol)).Select Selection.NumberFormat = "#,##0" End If End If Cells(14, 1).Select ElseIf wSheet.Name = "Detail" Then If lLastRow >= 20 And lLastCol >= 6 Then Range(Cells(20, 6), Cells(lLastRow, lLastCol)).Select Selection.NumberFormat = "#,##0" End If End If End If Next While BECell <> "" ' ts.Write "GlobalFormattingVer01 цикл по БЕ " & Date & " " & Time & CR_ ' ts.Write "BECell = " & BECell & CR_ ' ts.Write "x1 = " & x1 & CR_ ' ts.Write "RowCnt = " & RowCnt & CR_ & CR_
Worksheets(Sourse).Activate StrADDRess = Worksheets(Sourse).Range(Cells(x1, yOffset + 1), Cells(x1 + RowCnt - 1, y1)).Address ' Вставка от 17.05.2012 НР For k = LBound(BE_Arr, 2) To UBound(BE_Arr, 2) If BECell = BE_Arr(1, k) Then BE_Name = BE_Arr(2, k) CopyValue StrADDRess, BE_Name, Sourse, "G14" Worksheets(BE_Name).Select ' Копирование формата ячеек колонки M листа Свод lLastRow = Worksheets(BE_Name).Cells.SpecialCells(xlLastCell).Row If lLastRow >= 14 Then vRange = Range("M14:M" & Trim(Str(lLastRow))).Value Worksheets("Свод").Range("M14:M" & Trim(Str(lLastRow))).Copy Range("M14:M" & Trim(Str(lLastRow))) Range("M14:M" & Trim(Str(lLastRow))).Value = vRange End If ' Конец копирования формата ячеек листа Свод Cells(14, 1).Select Exit For End If Next k ' Окончание вставки от 17.05.2012 НР ' Закомментарил 17.05.2012 НР 'If BECell = "G10" Then CopyValue StrADDRess, "УР", Sourse, "G14" 'If BECell = "G20" Then CopyValue StrADDRess, "АТ", Sourse, "G14" 'If BECell = "G30" Then CopyValue StrADDRess, "АК", Sourse, "G14" 'If BECell = "GQ0" Then CopyValue StrADDRess, "КОС", Sourse, "G14" 'If BECell = "G40" Then CopyValue StrADDRess, "ЮЖ", Sourse, "G14" 'If BECell = "GS0" Then CopyValue StrADDRess, "ШЫМ", Sourse, "G14" 'If BECell = "GS1" Then CopyValue StrADDRess, "АГП ШЫМ", Sourse, "G14" 'If BECell = "G41" Then CopyValue StrADDRess, "АГП", Sourse, "G14" 'If BECell = "G50" Then CopyValue StrADDRess, "УП", Sourse, "G14" 'If BECell = "G60" Then CopyValue StrADDRess, "КО", Sourse, "G14" 'If BECell = "G70" Then CopyValue StrADDRess, "АКТАУ", Sourse, "G14" 'If BECell = "G80" Then CopyValue StrADDRess, "ТАРАЗ", Sourse, "G14" 'If BECell = "G81" Then CopyValue StrADDRess, "АГП ТАРАЗ", Sourse, "G14" 'If BECell = "G90" Then CopyValue StrADDRess, "УКК", Sourse, "G14" 'If BECell = "G99" Then CopyValue StrADDRess, "ГО", Sourse, "G14" 'If BECell = "GA0" Then CopyValue StrADDRess, "УАВРиСТ", Sourse, "G14" 'If BECell = "GA1" Then CopyValue StrADDRess, "АГП УАВРиСТ", Sourse, "G14" 'If BECell = "G32" Then CopyValue StrADDRess, "ББШ Актобе", Sourse, "G14" 'If BECell = "G42" Then CopyValue StrADDRess, "ББШ Южный", Sourse, "G14" 'If BECell = "G62" Then CopyValue StrADDRess, "ББШ Кызылорда", Sourse, "G14" 'If BECell = "G72" Then CopyValue StrADDRess, "ББШ Актау", Sourse, "G14" 'If BECell = "GA2" Then CopyValue StrADDRess, "ББШ УАВРиСТ", Sourse, "G14" 'If BECell = "GQ2" Then CopyValue StrADDRess, "ББШ Костанай", Sourse, "G14" 'If BECell = "GS2" Then CopyValue StrADDRess, "ББШ Шымкент", Sourse, "G14" ' Конец закомментаренного куска 17.05.2012 НР
x1 = x1 + RowCnt BECell = Worksheets(Sourse).Cells(x1, 1).Value Wend ' Application.ScreenUpdating = True
Worksheets("Свод").Activate End Sub
Sub CopyValue(ByVal gggd As String, Prn As String, ByVal Sourse As String, ByVal TargetCell As String) Dim lLastRow As Long, iFound As Long, k As Long If gggd = "" Then Exit Sub
' ts.Write "CopyValue: " & Date & " " & Time & CR_ ' ts.Write "gggd = " & gggd & CR_ ' ts.Write "Prn = " & Prn & CR_ ' ts.Write "Sourse = " & Sourse & CR_ ' ts.Write "TargetCell = " & TargetCell & CR_ & CR_
' Копировать данные Set rRang = Worksheets(Sourse).Range(gggd) ' rRang.Interior.ColorIndex = xlNone ' Worksheets(Sourse).Range(gggd).Copy 'вставить значения rRang.Copy Sheets(Prn).Range(TargetCell) ' Sheets(Prn).Select ' Range(TargetCell).Select ' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'вставить формат ' Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'цвет белый ' Selection.Interior.ColorIndex = xlNone
iFound = 0 For k = LBound(BE_Arr, 2) To UBound(BE_Arr, 2) If Prn = BE_Arr(2, k) Then iFound = k Exit For End If Next k
If iFound > 0 Then Sourse = "Свод" ' Закомментарил 17.05.2012 НР ' gggd = "A14:C5000" ' TargetCell = "A14" ' Окончание закомментаренного куска 17.05.2012 НР ' Вставка от 17.05.2012 НР lLastRow = Worksheets(Sourse).Cells.SpecialCells(xlLastCell).Row If lLastRow >= 14 Then gggd = "A14:C" & Trim(Str(lLastRow)) TargetCell = "A14:A14" ' Окончание вставки от 17.05.2012 НР Set rRang = Worksheets(Sourse).Range(gggd) ' Worksheets(Sourse).Range(gggd).Copy 'вставить значения ' Sheets(Prn).Select ' Range(TargetCell).Select ' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False rRang.Copy Sheets(Prn).Range(TargetCell) End If End If
If False Then Sourse = "Свод" ' Вставка от 17.05.2012 НР lLastRow = Worksheets(Sourse).Cells.SpecialCells(xlLastCell).Row If lLastRow >= 14 Then gggd = "A14:C" & Trim(Str(lLastRow)) TargetCell = "A14:A14" ' Окончание вставки от 17.05.2012 НР ' Закомментарил 17.05.2012 НР ' gggd = "A14:AA5000" ' TargetCell = "A14" ' Окончание закомментаренного куска 17.05.2012 НР Worksheets(Sourse).Range(gggd).Copy 'вставить формат Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'цвет белый Selection.Interior.ColorIndex = xlNone ' Вставка от 17.05.2012 НР End If End If ' Окончание вставки от 17.05.2012 НР
' Вставка от 17.05.2012 НР ' Worksheets(Sourse).Range(gggd).Copy Sheets(Prn).Range(TargetCell) ' Окончание вставки от 17.05.2012 НР End Sub
Sub Clear(Prn As String, Begin_Row As Long) Dim lLastRow As Long, k As Long, Beg_Row As Long Dim rDest As Range
' ts.Write "Clear: " & Date & " " & Time & CR_ ' ts.Write "Prn = " & Prn & CR_ ' ts.Write "Begin_Row = " & Begin_Row & CR_ & CR_
lLastRow = Worksheets(Prn).Cells.SpecialCells(xlLastCell).Row Set rDest = Nothing If Begin_Row > 0 Then Beg_Row = Begin_Row Else Beg_Row = 14 End If For k = Beg_Row To lLastRow If rDest Is Nothing Then Set rDest = Worksheets(Prn).Rows(k) Else Set rDest = Union(rDest, Worksheets(Prn).Rows(k)) End If Next k If lLastRow >= Beg_Row Then rDest.Delete End If ' Worksheets(Prn).Range("A14:Z5000").Delete Shift:=xlUp End Sub
Sub Del_Col(Prn As String, Begin_Col As Long) Dim lLastCol As Long, k As Long, Beg_Col As Long Dim rDest As Range
' ts.Write "Clear: " & Date & " " & Time & CR_ ' ts.Write "Prn = " & Prn & CR_ ' ts.Write "Begin_Col = " & Begin_Col & CR_ & CR_
lLastCol = Worksheets(Prn).Cells.SpecialCells(xlLastCell).Column Set rDest = Nothing If Begin_Col > 0 Then Beg_Col = Begin_Col Else Beg_Col = 5 End If For k = Beg_Col To lLastCol If rDest Is Nothing Then Set rDest = Worksheets(Prn).Columns(k) Else Set rDest = Union(rDest, Worksheets(Prn).Columns(k)) End If Next k If lLastCol >= Beg_Col Then rDest.Delete End If ' Worksheets(Prn).Range("A14:Z5000").Delete Shift:=xlUp End Sub
Sub Main(Prn As String) Dim s_ As String Dim iNum As Long Dim Sourse As String Dim dx As Long, delta As Long, f As Long
' ts.Write "MAIN: " & Date & " " & Time & CR_ ' ts.Write "Prn = " & Prn & CR_ & CR_
Sourse = "Main" dx = MainResult.Rows.Count + MainResult.Row - 1 Set rRang = Worksheets(Sourse).Range("A" + Trim(Str(MainResult.Row + 2)) + ":A" + Trim(Str(dx))) ' Worksheets(Sourse).Range("A" + Trim(Str(MainResult.Row + 2)) + ":A" + Trim(Str(dx))).Copy 'вставить значения rRang.Copy Sheets(Prn).Range("C14:C14") ' Sheets(Prn).Select ' Range("C14").Select ' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'вставить формат ' Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'цвет белый ' Selection.Interior.ColorIndex = xlNone 'Копировать данные Set rRang = Worksheets(Sourse).Range("B" + Trim(Str(MainResult.Row + 2)) + ":C" + Trim(Str(dx))) ' Worksheets(Sourse).Range("B" + Trim(Str(MainResult.Row + 2)) + ":B" + Trim(Str(dx))).Copy 'вставить значения rRang.Copy Sheets(Prn).Range("A14:B14") ' Sheets(Prn).Select ' Range("A14").Select ' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'вставить формат ' Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'цвет белый ' Selection.Interior.ColorIndex = xlNone
' Set rRang = Worksheets(Sourse).Range("B" + Trim(Str(MainResult.Row + 2)) + ":B" + Trim(Str(dx))) ' Worksheets(Sourse).Range("B" + Trim(Str(MainResult.Row + 2)) + ":B" + Trim(Str(dx))).Copy Worksheets(Prn).Select ' Range("B14").Select 'вставить формат ' rRang.Copy Sheets(Prn).Range("B14:B14") ' Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' Selection.Interior.ColorIndex = xlNone
'Exit Sub
delta = 4 ' ts.Write "MAIN: for each c dx = " & dx & " begin " & Date & " " & Time & CR_ ' For Each c In Worksheets(Prn).Range("F14:F" + Trim(Str(dx - delta))) Worksheets(Prn).Range("M14:M" & Trim(Str(dx - delta))).Font.Underline = True Worksheets(Prn).Range("A14:B" & Trim(Str(dx - delta))).NumberFormat = "@" For iNum = 14 To dx - delta ' If InStr(Worksheets(Sourse).Cells(c.Row + delta, 4).Value, "#") = 0 And Worksheets(Sourse).Cells(c.Row + delta, 4).Value <> "" Then' If Len(Worksheets(Sourse).Cells(iNum + delta, 4).Value) <= 5 Then ' MsgBox Worksheets(Sourse).Cells(c.Row + delta, 4).Value Cells(iNum, 13).Font.Underline = False End If If InStr(Trim(Cells(iNum, 1).Value), ".") = 0 Then s_ = Cells(iNum, 1).Value Cells(iNum, 1).Value = Worksheets(Prn).Cells(iNum, 2).Value Cells(iNum, 2).Value = s_ End If
If False Then If InStr(Worksheets(Sourse).Cells(iNum + delta, 3).Value, "#") = 0 And Worksheets(Sourse).Cells(iNum + delta, 3).Value <> "" Then Cells(iNum, 1).NumberFormat = "@" Cells(iNum, 1).Value = Worksheets(Sourse).Cells(iNum + delta, 3).Value End If End If
If Left(Trim(Cells(iNum, 1).Value), 1) = "Z" Then Cells(iNum, 1).Value = Cells(iNum, 2).Value Cells(iNum, 2).Value = "" End If
If Right(Trim(Cells(iNum, 1).Value), 1) <> "." Then ' Cells(iNum, 2).NumberFormat = "@" Cells(iNum, 1).Value = Cells(iNum, 1).Value & "." End If
' Cells(iNum, 2).Value = Replace(Worksheets(Prn).Cells(iNum, 2).Value, "Z", "") ' Cells(iNum, 6).WrapText = True Next iNum ' ts.Write "MAIN: for each c end " & Date & " " & Time & CR_ & CR_
f = dx + 1 Worksheets(Prn).Range("A3:A4").Font.Bold = True Worksheets(Prn).Range("A3:A4").Font.Size = 14 ' Rows("1:1").Select
'Страница 'Выключаем отображение на экран для повышения скорости работы. ' Call SM("АГП", "УР", dx) ' Call SM("АГП", "АТ", dx) ' Call SM("АГП", "УП", dx) ' Call SM("АГП", "ЮЖ", dx) ' Call SM("АГП", "КО", dx) Call SM("Свод", "2", dx - delta) ' Call SM("АГП", "Свод", dx) ' Call SM("АГП", "ГО", dx) ' Call SM("АГП", "АКТАУ", dx) ' Call SM("АГП", "ТАРАЗ", dx) ' Call SM("АГП", "УКК", dx) End Sub
Sub SM(Sourse As String, ByVal Prn As String, ByVal Bx As Integer) Dim iNum As Long
' ts.Write "SM: " & Date & " " & Time & CR_ ' ts.Write "Sourse = " & Sourse & CR_ ' ts.Write "Prn = " & Prn & CR_ ' ts.Write "Bx = " & Bx & CR_ & CR_
Set rRang = Worksheets(Sourse).Range("A14:F" + Trim(Str(Bx))) ' + 10))) ' Worksheets(Sourse).Range("A14:F" + Trim(Str(Bx + 10))).Copy 'вставить значения ' Worksheets(Prn).Select ' Range("A14").Activate rRang.Copy Sheets(Prn).Range("A14:A14") ' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'вставить формат ' Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' ts.Write "SM for each c Bx = " & Bx & " begin: " & Date & " " & Time & CR_ Set rRang = Worksheets(Sourse).Range("M14:M" + Trim(Str(Bx))) ' + 10))) ' Worksheets(Sourse).Range("M14:M" + Trim(Str(Bx + 10))).Copy 'вставить значения rRang.Copy Sheets(Prn).Range("M14:M14") ' Worksheets(Prn).Select ' Range("M14").Activate 'вставить формат ' Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' For Each c In Worksheets(Prn).Range("M14:M" + Trim(Str(Bx + 10))) ' For iNum = 14 To Bx + 10 ' Cells(iNum, 13).Font.Underline = Worksheets(Sourse).Cells(iNum, 13).Font.Underline ' Cells(iNum, 13).NumberFormat = Worksheets(Sourse).Cells(iNum, 13).NumberFormat ' Cells(iNum, 13).WrapText = Worksheets(Sourse).Cells(iNum, 13).WrapText ' Next ' ts.Write "SM for each c end: " & Date & " " & Time & CR_ & CR_
On Error Resume Next
Worksheets(Prn).PageSetup.RightFooter = "Страница &С из &К" End Sub
Function ColumnAddress(ColNum As Integer) Dim i As Integer, j As Integer Dim Result As String i = Int(ColNum / 26) j = ColNum Mod 26 If j = 0 Then i = i - 1 j = 26 End If If i > 0 And i <= 26 Then Result = Chr(64 + i) Else Result = "" End If Result = Result & Chr(64 + j) ColumnAddress = Result End Function
|
|