Текущее время: Чт, мар 28 2024, 17:35

Часовой пояс: UTC + 3 часа




Начать новую тему Ответить на тему  [ Сообщений: 8 ] 
Автор Сообщение
 Заголовок сообщения: Слетел макрос в рабочей книге BW
СообщениеДобавлено: Вт, окт 16 2018, 16:48 
Начинающий
Начинающий

Зарегистрирован:
Пн, июн 06 2011, 12:24
Сообщения: 18
Пол: Женский
Здравствуйте, есть отчет, рабочая книга с макросом, не известно по какой причине перестал работать. При запуске выбрасывает следующая ошибка в VBA:

Compile error
Variable not defined

и выделяется Setup из следующего фрагмента:

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


Подскажите пожалуйста, какие есть решения для возврата работоспособности отчета? Из ошибки понимаю, что переменная не определена. но что из себя представляет Setup?


Принять этот ответ
Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Слетел макрос в рабочей книге BW
СообщениеДобавлено: Вт, окт 16 2018, 17:41 
Почетный гуру
Почетный гуру

Зарегистрирован:
Чт, фев 03 2005, 10:18
Сообщения: 503
Добрый день.
Не видя самой книги можно только предполагать "что в черном ящике".

Мое предположение, что это техническое имя настроечного листа.


Принять этот ответ
Вернуться к началу
 Профиль  
 
 Заголовок сообщения: Re: Слетел макрос в рабочей книге BW
СообщениеДобавлено: Чт, окт 18 2018, 12:12 
Начинающий
Начинающий

Зарегистрирован:
Чт, май 08 2014, 14:17
Сообщения: 18
Без всего текста макроса тяжело судить, что слетело + хорошо бы увидеть книгу, хотя бы диспетчер имён.


Принять этот ответ
Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Слетел макрос в рабочей книге BW
СообщениеДобавлено: Пт, окт 19 2018, 12:15 
Начинающий
Начинающий

Зарегистрирован:
Пн, июн 06 2011, 12:24
Сообщения: 18
Пол: Женский
Добрый день, спасибо за ответы. А как посмотреть диспетчер имен в рабочей книге?
Ниже весь макрос:

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


Принять этот ответ
Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Слетел макрос в рабочей книге BW
СообщениеДобавлено: Пт, окт 19 2018, 15:03 
Почетный гуру
Почетный гуру

Зарегистрирован:
Чт, фев 03 2005, 10:18
Сообщения: 503
Почитайте статью по ссылке, обратив внимание на вариант 4.
http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/sheet_happens/7-1-0-96


Принять этот ответ
Вернуться к началу
 Профиль  
 
 Заголовок сообщения: Re: Слетел макрос в рабочей книге BW
СообщениеДобавлено: Пт, окт 19 2018, 15:15 
Начинающий
Начинающий

Зарегистрирован:
Пн, июн 06 2011, 12:24
Сообщения: 18
Пол: Женский
Такого Листа "Setup" в рабочей книге нет, может быть он должен как-то появляться сам сформировываться. Даже в ручную добавляя такой Лист "Setup", макрос все равно не отрабатывает.


Принять этот ответ
Вернуться к началу
 Профиль Отправить email  
 
 Заголовок сообщения: Re: Слетел макрос в рабочей книге BW
СообщениеДобавлено: Пт, окт 19 2018, 15:33 
Почетный гуру
Почетный гуру

Зарегистрирован:
Чт, фев 03 2005, 10:18
Сообщения: 503
Судя по коду макроса этот лист должен содержать определенные настройки для формирования отчета.

' Заполнение массива БЕ
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


Принять этот ответ
Вернуться к началу
 Профиль  
 
 Заголовок сообщения: Re: Слетел макрос в рабочей книге BW
СообщениеДобавлено: Чт, окт 25 2018, 14:12 
Начинающий
Начинающий

Зарегистрирован:
Чт, май 08 2014, 14:17
Сообщения: 18
Цитата:
А как посмотреть диспетчер имен в рабочей книге?

открыть эксель -> Вкладка формулы -> диспетчер имён

Цитата:
Такого Листа "Setup" в рабочей книге нет, может быть он должен как-то появляться сам сформировываться. Даже в ручную добавляя такой Лист "Setup", макрос все равно не отрабатывает.

Setup - это переменная, соответствующая листу в книге

Например у вас есть настроенный лист с названием "Настройка", тогда нужно добавить после

Code:
Option Explicit


следующее:

Code:
Public Setup As Worksheet
    Set Setup = Sheet("Настройка")


Принять этот ответ
Вернуться к началу
 Профиль Отправить email  
 
Показать сообщения за:  Поле сортировки  
Начать новую тему Ответить на тему  [ Сообщений: 8 ] 

Часовой пояс: UTC + 3 часа


Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей


Вы не можете начинать темы
Вы не можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
cron
Powered by phpBB © 2000, 2002, 2005, 2007 phpBB Group
Русская поддержка phpBB