Полезные макросы для Excel

Макрос для интерактивного добавления фотографий

При наличии на листе ячеек, содержащих имя фотографии в формате jpg, макрос вставляет в данную ячейку указанную фотографию.

Удобно использовать в сводных таблицах: создаем поле группировки "Фото", в котором выводим наименование файлов картинок, макрос вызываем событием Worksheet_PivotTableUpdate. При удалении группировки по столбцу "Фото" все картинки на листе будут удалены. При любом изменении структуры сводной таблицы, фотографии будут перезакреплены.

Sub foto()

    On Error GoTo lab

    Application.StatusBar = "Проставляем фото"

    Application.ScreenUpdating = False

    For Each Pic In ActiveSheet.Shapes 'удаляем все картинки на текущем листе

        If Pic.Type = msoPicture Or Pic.Type = msoLinkedPicture Then Pic.Delete

    Next

    ActiveSheet.UsedRange.EntireRow.AutoFit

    'проверяем наличие поля "Фото" (для сводной не использовать)

    If ActiveSheet.UsedRange.Find(what:="Фото", LookAt:=xlWhole) Is Nothing Then GoTo lab

    'оптимизация поиска при работе со сводной

    'Dim pt As PivotTable

    'Set pt = ActiveSheet.PivotTables(1)

    'проставляем фото из указанной директории

    For Each c In ActiveSheet.UsedRange 'In pt.PivotFields("Фото").DataRange.Cells

        If InStr(c.Value, ".jpg") > 0 Then

            c.ColumnWidth = 10

            filepath = "c:\photo\" & LTrim(Left(c.Value, InStr(c.Value, ".jpg") + 3)) 'указать каталог с фотографиями

            on error goto er

            Set ph = c.Parent.Pictures.Insert(filepath)

            on error goto lab

            ph.Top = c.Top: ph.Left = c.Left: k = ph.Width / ph.Height

            ph.Width = c.Width: ph.Height = ph.Width / k

            c.EntireRow.RowHeight = ph.Height + 1

            ph.Placement = xlMoveAndSize

            Application.StatusBar = "Вставляю фото. Выполнено " & Round((c.Row / ActiveSheet.UsedRange.Rows.Count * 100), 2) & " %. Обработано " & c.Row & " товаров из " & ActiveSheet.UsedRange.Rows.Count

            'Application.StatusBar = "Выводим фото. Выполнено " & Round((c.Row / pt.PivotFields("Фото").DataRange.Rows.Count * 100), 2) & " %. Обработано " & c.Row & " строк из " & pt.PivotFields("Фото").DataRange.Rows.Count

        End If

        er: set ph=nothing

    Next

lab: Application.StatusBar = "Готово"

    If (Err.Number <> 1004) And (Err.Number <> 0) Then MsgBox "Произошла ошибка # " & Str(Err.Number) & " сгенерирована " & Err.Source & Chr(13) & Err.Description

    Application.ScreenUpdating = True

End Sub

Макрос для формализации сводной таблицы

Заполняет пустые ячейки значениями сверху вниз.

Перед запуском необходимо выбрать одну или несколько значащих ячеек из соседних столбцов, с которых начнется обработка.

Sub Fill_The_Name()

Dim s As Variant

Dim i, j As Integer

    s = ActiveCell.Value

    For j = ActiveCell.Column To Selection.Columns.count + ActiveCell.Column

        For i = ActiveCell.Row + 1 To ActiveCell.SpecialCells(xlLastCell).Row

            If (IsEmpty(Cells(i, j))) Or (Cells(i, j) = " ") Then Cells(i, j) = s Else s = Cells(i, j)

        Next i

        s = Cells(ActiveCell.Row, j + 1)

    Next j

End Sub

Макрос для удаления скрытых картинок с листа Excel

Если высота картинки меньше 5 уе, то она будет удалена.

Sub Pict_hidden_delete()

Dim Shp As Object

Application.ScreenUpdating = False

On Error Resume Next

For Each Shp In ActiveSheet.Shapes

With Shp

If (.Type = msoPicture) Or (.Type = msoLinkedPicture) Then

If .Height< 5 Then .Delete 'критерий отбора жертвы

End If

End With

Next

Application.ScreenUpdating = True

End Sub

PS работа с картинками в Excel - отдельная песня, правильней использовать СУБД.

Макрос для удаления чуждых символов (иероглифов)

Перед запуском выделить обрабатываемую область листа Excel.

Sub remove_unicode()

Dim st, st2 As String

For Each c In Selection

st = ""

For j = 1 To Len(c.Value)

simv = AscW(Mid(c.Value, j, 1))

If (simv > 10) And (simv < 2000) Then st = st +ChrW(simv)

Next j

c.Value = Trim(st)

Next

End Sub

Макрос для преобразования размерной сетки в построчный формат

Sub transf_razm_setki()

'преобразование размерной сетки в построчные размеры для загрузки на сайт

'в первом столбце размерная сетка через запятую

'во второй столбец выводится размер данной строки

i = 3

While Len(Cells(i, 1)) > 0

If InStr(Cells(i, 1), ",") > 0 Then

Rows(i).Select

Application.CutCopyMode = False

Selection.Copy

Rows(i + 1).Select

Selection.Insert Shift:=xlDown

Cells(i + 1, 1) = Trim(Right(Cells(i, 1), Len(Cells(i, 1)) - InStr(Cells(i, 1), ",")))

Cells(i, 2) = Trim(Left(Cells(i, 1), InStr(Cells(i, 1), ",") - 1))

Else: Cells(i, 2) = Cells(i, 1)

End If

i = i + 1

Wend

End Sub