Код: Выделить всё
Option Explicit
Public Sub MainVBA()
' (С) 2011 ElbuzGroup, for E-Trade PriceList Importer
Dim lngSheetID As Long ' номер листа с которым работать
Dim lngRowSourceCur As Long
Dim lngRowsCount As Long
Dim varNewFileName As Variant
Dim fs As Variant
Dim i As Long, x As Long
Dim Категория As String
Dim Производитель As String
Application.ScreenUpdating = False
' Корректируем
For lngSheetID=5 TO WorkSheets.Count
Worksheets(lngSheetID).Activate
Cells.ColumnWidth = 12
Cells.WrapText = False
For i = 4 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 5) <> 0 Then
Cells(i, 11) = Cells(i, 5) + Cells(i, 8)
End If
Next i
Next lngSheetID
Worksheets(1).Activate
' Сохраняем данные в новом файле из буфера обмена
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