Sub Заполнение_пустот_нолями() ' В выделении находим пустые ячейки и зануляем их For Each Cell In Selection If Cell.value = "" Then Cell.value = "0" Next End Sub Sub Поиск_повторений() ' В выделении находим ячейки с одинаковыми значениями ' и выделяем их цветом Dim Count As Integer For Each Cell In Selection If Cell.value <> "" Then Count = 0 For Each Cell2 In Selection If Cell.value = Cell2.value Then Count = Count + 1 Next If Count > 1 Then With Cell.Interior .ColorIndex = 4 End With End If End If Next End Sub Sub Убрать_пробелы_по_краям() ' В выделении уберем во всех ячейках лишние пробелы Dim Count As Integer For Each Cell In Selection If Cell.value <> "" Then 1: Count = 0 If Left(Cell.value, 1) = " " Then Cell.value = Right(Cell.value, Len(Cell.value) - 1) Count = Count + 1 End If If Right(Cell.value, 1) = " " Then Cell.value = Left(Cell.value, Len(Cell.value) - 1) Count = Count + 1 End If If Count > 0 Then GoTo 1 End If Next End Sub Sub DelIndifferentFont() ' ' Удалить все строки, в которых шрифт отличается от шрифта ' первой ячейки выбора ' Dim FontSize, FontBold Dim WasDeleted ' сохраним параметры оригинального шрифта FontSize = Cells(Selection.Row, Selection.Column).Font.Size FontBold = Cells(Selection.Row, Selection.Column).Font.Bold For i = 1 To Selection.Count WasDeleted = False For Each Cell In Selection If (Cell.Font.Size <> FontSize) Or _ (Cell.Font.Bold <> FontBold) Or _ (Cell.value = "") Then Rows(Cell.Row).Delete Shift:=xlUp WasDeleted = True End If Next If Not WasDeleted Then Exit For Next End Sub Sub DelSameRows() ' ' Макрос записан 18.10.2007 (Alexey V. Nikitayev) ' Удалим повторяющиеся строки ' Dim CurrRow, i, CurrColumn Dim FontSize, FontBold ' сохраним текущую строку и столбец CurrColumn = Selection.Column CurrRow = Selection.Row + 1 ' идём на много (40000) строк вниз и удаляем повторения For i = 1 To 40000 If (Cells(CurrRow, CurrColumn) = Cells(CurrRow - 1, CurrColumn)) Then Rows(CurrRow).Delete Shift:=xlUp Else CurrRow = CurrRow + 1 End If ' если ниже ничего нет - то прерываем обработку If (Cells(CurrRow, CurrColumn) = "") Then Exit For End If Next End Sub Sub CollectInfoByMonth() ' ' Макрос записан 18.10.2007 (Alexey V. Nikitayev) ' Сбор для каждого наименования со всех страниц данных о продажах по месяцам ' Цель - собрать результирующие данные ' Должна быть выделена первая ячейка - с неё возьмём номер первой строки ' Dim CurrSheet, ReportSheet Dim FirstRow, FirstColumn, CurrRow, i, j ' сохраним текущую строку и столбец FirstRow = Selection.Row FirstColumn = Selection.Column CurrRow = 1 ReportSheet = Worksheets.Count FirstMonthColumn = 2 FirstReportColumn = 4 TotalMonthCount = 6 ' идём по всем месяцам For CurrSheet = 1 To TotalMonthCount ' сбросим счётчик первой строки (применяется только для оптимизации) NextRowBegin = 11 ' идём по столбцу названий в итоговом отчёте For i = FirstRow To FirstRow + 20000 ' ищем текущую позицию на листе месяца №CurrSheet - пробегаем его For CurrRow = NextRowBegin To 20000 If Worksheets(CurrSheet).Cells(CurrRow, FirstMonthColumn) = _ Worksheets(ReportSheet).Cells(i, FirstColumn) Then 'если нашли упоминание о данном товаре - заполним ячейки отчёта ' количество - 12-й столбец Worksheets(ReportSheet).Cells(i, FirstReportColumn) = _ Worksheets(CurrSheet).Cells(CurrRow, 12) ' сумма - 13-й столбец Worksheets(ReportSheet).Cells(i, FirstReportColumn + 1) = _ Worksheets(CurrSheet).Cells(CurrRow, 13) ' доход - 18-й столбец Worksheets(ReportSheet).Cells(i, FirstReportColumn + 2) = _ Worksheets(CurrSheet).Cells(CurrRow, 18) ' % наценки - 19-й столбец Worksheets(ReportSheet).Cells(i, FirstReportColumn + 3) = _ Worksheets(CurrSheet).Cells(CurrRow, 19) ' оборачиваемость - 22-й столбец Worksheets(ReportSheet).Cells(i, FirstReportColumn + 5) = _ Worksheets(CurrSheet).Cells(CurrRow, 22) NextRowBegin = CurrRow Exit For End If ' если ниже ничего нет или нет такой позиции - то переходим к следующему месяцу If (Worksheets(CurrSheet).Cells(CurrRow, FirstMonthColumn) = "") Or _ (Worksheets(CurrSheet).Cells(CurrRow, FirstMonthColumn) > _ Worksheets(ReportSheet).Cells(i, FirstColumn)) Then Exit For End If Next If Worksheets(ReportSheet).Cells(i, FirstColumn) = "" Then Exit For End If Next ' если ниже ничего нет - то прерываем обработку FirstReportColumn = FirstReportColumn + 6 Next End Sub Sub SelectAllDataToOneSheet() ' ' Макрос записан 18.10.2007 (Alexey V. Nikitayev) ' Цель - создать отдельный лист и туда собрать все записи с повторениями ' Должна быть выделена первая ячейка - с неё возьмём номер первой строки ' Dim CurrSheet, ReportSheet Dim FirstRow, FirstColumn, CurrRow, i, j ' сохраним текущую строку и столбец FirstRow = Selection.Row FirstColumn = Selection.Column ' добавим пустой лист Worksheets.Add After:=Sheets(Sheets.Count) CurrRow = 1 ReportSheet = Worksheets.Count ' идём по всем предыдущим страницам - там должны быть отсортированные отчёты For CurrSheet = 1 To Worksheets.Count - 1 For i = FirstRow To FirstRow + 20000 If Worksheets(CurrSheet).Cells(i, FirstColumn) <> "" Then For j = 1 To 100 Worksheets(ReportSheet).Cells(CurrRow, j) = _ Worksheets(CurrSheet).Cells(i, j) Next CurrRow = CurrRow + 1 End If Next Next End Sub Type valuetype value As Double idx As Integer End Type Sub AutomaticReportForCorrelationAnalysis() ' Анализ таблицы корелляционного анализа (Сервис->Анализ данных...->Корреляция) ' Automatic report for correlation analysis ' Service -> Data analysis... -> Correlation ' Макрос записан 12.01.2008 (Alexey V. Nikitayev) ' Цель - для каждого товара найти сопутствующие и замещающие. ' Должен быть выделен лист с данными корреляционного анализа ' 1. Найдём количество элементов maxrows = 1 For x = 2 To 1000 If Application.ActiveSheet.Cells(1, x).value <> "" Then maxrows = maxrows + 1 Else Exit For Next Dim maxvalues(3) As valuetype Dim minvalues(3) As valuetype ' 2. Цикл по столбцам For x = 2 To maxrows ' 3. Очистим значения максимальных сопутствующих и замещающих For i = 1 To 3 maxvalues(i).value = -10 maxvalues(i).idx = 1 minvalues(i).value = 10 minvalues(i).idx = 1 Next ' 4. Ищем максимальные величины корелляции в текущем столбце For y = x + 1 To maxrows CurrValue = Application.ActiveSheet.Cells(y, x).value If maxvalues(1).value < CurrValue Then maxvalues(3) = maxvalues(2) maxvalues(2) = maxvalues(1) maxvalues(1).value = CurrValue maxvalues(1).idx = y ElseIf maxvalues(2).value < CurrValue Then maxvalues(3) = maxvalues(2) maxvalues(2).value = CurrValue maxvalues(2).idx = y ElseIf maxvalues(3).value < CurrValue Then maxvalues(3).value = CurrValue maxvalues(3).idx = y End If If minvalues(1).value > CurrValue Then minvalues(3) = minvalues(2) minvalues(2) = minvalues(1) minvalues(1).value = CurrValue minvalues(1).idx = y ElseIf minvalues(2).value > CurrValue Then minvalues(3) = minvalues(2) minvalues(2).value = CurrValue minvalues(2).idx = y ElseIf minvalues(3).value > CurrValue Then minvalues(3).value = CurrValue minvalues(3).idx = y End If Next ' 5. Выводим результат поисков Application.ActiveSheet.Cells(maxrows + 1, x).value = Application.ActiveSheet.Cells(1, x).value Application.ActiveSheet.Cells(maxrows + 2, x).value = "Продаётся вместе с:" If maxvalues(1).value > 0.7 Then Application.ActiveSheet.Cells(maxrows + 3, x).value = Application.ActiveSheet.Cells(maxvalues(1).idx, 1).value If maxvalues(2).value > 0.7 Then Application.ActiveSheet.Cells(maxrows + 4, x).value = Application.ActiveSheet.Cells(maxvalues(2).idx, 1).value If maxvalues(3).value > 0.7 Then Application.ActiveSheet.Cells(maxrows + 5, x).value = Application.ActiveSheet.Cells(maxvalues(3).idx, 1).value End If End If End If Application.ActiveSheet.Cells(maxrows + 7, x).value = "Вытесняется:" If minvalues(1).value < -0.5 Then Application.ActiveSheet.Cells(maxrows + 8, x).value = Application.ActiveSheet.Cells(minvalues(1).idx, 1).value If minvalues(2).value < -0.5 Then Application.ActiveSheet.Cells(maxrows + 9, x).value = Application.ActiveSheet.Cells(minvalues(2).idx, 1).value If minvalues(3).value < -0.5 Then Application.ActiveSheet.Cells(maxrows + 10, x).value = Application.ActiveSheet.Cells(minvalues(3).idx, 1).value End If End If End If Next End Sub