Обсуждение и советы: создание интернет-магазинов - решения, процессы, прайсинг

Код: Выделить всё

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