Страница 1 из 2
Ошибка обработки макросов
Добавлено: 07 фев 2014 14:40
krasenkov
Здравствуйте, подскажите можно как-то вылечить эту ошибку?
Настройка макросов VBA - Проверить макрос на прайс-листе
Выдает ошибку, см. скриншот.
Ну и понятное дело, эта ошибка стопорит импорт при импорте всех прайсов.
В настройках офиса макросы разрешены. Раньше все работало, а сейчас не понятно что произошло.
На новой базе ошибка не уходит, переустановка PLI с поднятием бекапа БД не помогает.
Макрос и прайс прилагается
Re: Ошибка обработки макросов
Добавлено: 10 фев 2014 10:42
support
Вероятнее всего ошибка в макросе. Обратитесь к разработчику макроса.
Re: Ошибка обработки макросов
Добавлено: 11 фев 2014 08:06
Ixenon
Привет, попробуй этот.
Re: Ошибка обработки макросов
Добавлено: 11 фев 2014 16:53
krasenkov
Ixenon писал(а):Привет, попробуй этот.
Что-то не хотит
Re: Ошибка обработки макросов
Добавлено: 11 фев 2014 18:25
Ixenon
Первый блин получился комом
Вот исправленный вариант.
Код: Выделить всё
Option Explicit
Public Sub MainVBA()
Dim lngSheetID As Long ' номер листа с которым работать
Dim varNewFileName As Variant
Dim fs As Variant
Dim i As Long
Dim j As Long
Dim RowsCount As Long
Dim ColumnsCount As Long
Dim PriceColumn As Long
Dim Brand As String
Dim Category As String
Dim FileNameInFull As String
Dim FileNameInDataModifySplit As Variant
Dim FileNameInDataModify As String
Application.ScreenUpdating = False
'Корректируем
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 1) <> "" And Trim(Cells(i, 2)) = "" Then
Category = Cells(i, 1)
Else
Cells(i, 5) = Category
If Cells(i, 1) <> "" And Trim(Cells(i, 2)) <> "" And Cells(i, 1).Interior.ColorIndex = 35 Then
Brand = Cells(i, 1)
Cells(i, 6) = Brand
Cells(i, 7) = Cells(i, 6) & " " & Cells(i, 2)
Else
Cells(i, 6) = Brand
Cells(i, 7) = Cells(i, 6) & " " & Cells(i, 2)
End If
End If
Next i
'Сохраняем данные в новом файле из буфера обмена
Set fs = CreateObject("Scripting.FileSystemObject")
varNewFileName = Replace(ActiveWorkbook.FullName, ActiveWorkbook.Name, "") & "_" & ActiveWorkbook.Name
If fs.FileExists(varNewFileName) = True Then
Kill varNewFileName
End If
Application.CutCopyMode = False
Application.DisplayAlerts = False
Dim nSourceFile As Long
Dim nDestFile As Long
Dim nTotalSheets As Long
Dim nSheetsAdd As Long
nSourceFile = Workbooks.Count
nTotalSheets = Workbooks.Item(nSourceFile).Worksheets.Count
Workbooks.Add
nDestFile = Workbooks.Count
If nTotalSheets > 3 Then
For nSheetsAdd = 1 To nTotalSheets - 3
Workbooks.Item(nDestFile).Sheets.Add
Next nSheetsAdd
End If
For lngSheetID = 1 To nTotalSheets
Workbooks.Item(nSourceFile).Sheets.Item(lngSheetID).Activate ' активируем лист источник
Workbooks.Item(nSourceFile).Sheets.Item(lngSheetID).UsedRange.Copy
Workbooks.Item(nDestFile).Sheets.Item(lngSheetID).Activate ' активируем новый лист
Workbooks.Item(nDestFile).Sheets.Item(lngSheetID).Paste
Workbooks.Item(nDestFile).Sheets.Item(lngSheetID).Name = Workbooks.Item(nSourceFile).Sheets.Item(lngSheetID).Name
Next lngSheetID
Workbooks.Item(nDestFile).Sheets.Item(1).Activate
Workbooks.Item(nSourceFile).Sheets.Item(1).Activate
Application.ScreenUpdating = True
Workbooks.Item(nDestFile).SaveAs varNewFileName, Workbooks.Item(nSourceFile).FileFormat, , , False, False, 1, 2
Workbooks.Item(nDestFile).Close
'Application.Quit
End Sub
Re: Ошибка обработки макросов
Добавлено: 11 фев 2014 19:10
krasenkov
Все равно что-то ругается
Re: Ошибка обработки макросов
Добавлено: 12 фев 2014 05:40
Ixenon
Попробуйте этот:
Код: Выделить всё
Option Explicit
Public Sub MainVBA()
Dim lngSheetID As Long ' номер листа с которым работать
Dim varNewFileName As String
Dim fs As Variant
Dim i As Long
Dim Brand As String
Dim Category As String
Application.ScreenUpdating = False
'Корректируем
On Error Resume Next
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 1) <> "" And Trim(Cells(i, 2)) = "" Then
Category = Cells(i, 1)
Else
Cells(i, 5) = Category
If Cells(i, 1) <> "" And Trim(Cells(i, 2)) <> "" And Cells(i, 1).Interior.ColorIndex = 35 Then
Brand = Cells(i, 1)
Cells(i, 6) = Brand
Cells(i, 7) = Cells(i, 6) & " " & Cells(i, 2)
Else
Cells(i, 6) = Brand
Cells(i, 7) = Cells(i, 6) & " " & Cells(i, 2)
End If
End If
Next i
'Сохраняем данные в новом файле из буфера обмена
Set fs = CreateObject("Scripting.FileSystemObject")
varNewFileName = Replace(ActiveWorkbook.FullName, ActiveWorkbook.Name, "") & "_" & ActiveWorkbook.Name
If fs.FileExists(varNewFileName) = True Then
Kill varNewFileName
End If
Application.CutCopyMode = False
Application.DisplayAlerts = False
Dim nSourceFile As Long
Dim nDestFile As Long
Dim nTotalSheets As Long
Dim nSheetsAdd As Long
nSourceFile = Workbooks.Count
nTotalSheets = Workbooks.Item(nSourceFile).Worksheets.Count
Workbooks.Add
nDestFile = Workbooks.Count
If nTotalSheets > 3 Then
For nSheetsAdd = 1 To nTotalSheets - 3
Workbooks.Item(nDestFile).Sheets.Add
Next nSheetsAdd
End If
For lngSheetID = 1 To nTotalSheets
Workbooks.Item(nSourceFile).Sheets.Item(lngSheetID).Activate ' активируем лист источник
Workbooks.Item(nSourceFile).Sheets.Item(lngSheetID).UsedRange.Copy
Workbooks.Item(nDestFile).Sheets.Item(lngSheetID).Activate ' активируем новый лист
Workbooks.Item(nDestFile).Sheets.Item(lngSheetID).Paste
Workbooks.Item(nDestFile).Sheets.Item(lngSheetID).Name = Workbooks.Item(nSourceFile).Sheets.Item(lngSheetID).Name
Next lngSheetID
Workbooks.Item(nDestFile).Sheets.Item(1).Activate
Workbooks.Item(nSourceFile).Sheets.Item(1).Activate
Application.ScreenUpdating = True
Workbooks.Item(nDestFile).SaveAs varNewFileName, Workbooks.Item(nSourceFile).FileFormat, , , False, False, 1, 2
Workbooks.Item(nDestFile).Close
'Application.Quit
End Sub
Re: Ошибка обработки макросов
Добавлено: 13 фев 2014 17:10
krasenkov
Работает, большое спасибо.
Re: Ошибка обработки макросов
Добавлено: 13 фев 2014 17:47
Ixenon
krasenkov писал(а):Работает, большое спасибо.
Пожалуста
Re: Ошибка обработки макросов
Добавлено: 23 фев 2016 19:12
Sancho.smadshop
Dim lngSheetID As Long ' номер листа с которым работать
Как прописать больше листов? Отпишитесь если кто в курсе. Если ничего не прописать - импортируется только первый лист.