Ошибка обработки макросов

[krasenkov]

Здравствуйте, подскажите можно как-то вылечить эту ошибку?
Настройка макросов VBA - Проверить макрос на прайс-листе
Выдает ошибку, см. скриншот.
Ну и понятное дело, эта ошибка стопорит импорт при импорте всех прайсов.
В настройках офиса макросы разрешены. Раньше все работало, а сейчас не понятно что произошло.
На новой базе ошибка не уходит, переустановка PLI с поднятием бекапа БД не помогает.
Макрос и прайс прилагается

[support]

Вероятнее всего ошибка в макросе. Обратитесь к разработчику макроса.

[Ixenon]

Привет, попробуй этот.

[krasenkov]

Привет, попробуй этот.

Что-то не хотит

[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

[krasenkov]

Все равно что-то ругается

[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

[krasenkov]

Работает, большое спасибо.

[Ixenon]

Работает, большое спасибо.

Пожалуста

[Sancho.smadshop]

Dim lngSheetID As Long ' номер листа с которым работать

Как прописать больше листов? Отпишитесь если кто в курсе. Если ничего не прописать - импортируется только первый лист.