Attribute VB_Name = "Module1"
Option Explicit
Option Base 1
Private Type typHEADER
    strType As String * 2  ' Сигнатура BMP-формата = "BM"
    lngSize As Long        ' Размер файла
    intRes1 As Integer     ' зарезервировано = 0
    intRes2 As Integer     ' зарезервировано = 0
    lngOffset As Long      ' смещение до данных растра (биты картинки)
End Type
Private Type typINFOHEADER
    lngSize As Long        ' Размер
    lngWidth As Long       ' Высота
    lngHeight As Long      ' Длина
    intPlanes As Integer   ' Количество слоев в файле
    intBits As Integer     ' Количество бит на пиксел (у нас RGB 24 бита)
    lngCompression As Long ' Тип компрессии (установлено в 0)
    lngImageSize As Long   ' Размер картинки (в байтах, установлено в 0)
    lngxResolution As Long ' Разрешение устройства по X (установлено в 0)
    lngyResolution As Long ' Разрешение устройства по Y (установлено в 0)
    lngColorCount As Long  ' Количество цветов (для 24 установлено в 0)
    lngImportantColors As Long ' "Важные" цвета (установлено в 0)
End Type
Private Type typPIXEL
    bytB As Byte    ' Blue, канал синего
    bytG As Byte    ' Green, канал зеленого
    bytR As Byte    ' Red, канал красного
End Type
Private Type typBITMAPFILE
    bmfh As typHEADER
    bmfi As typINFOHEADER
    bmbits() As Byte
End Type
'
' Генерирование имени файла из даты и времени.'
'
Function FileName() As String
    Dim currentTimeDate As Variant
    Dim iYear, iMonth, iDay As Integer
    Dim iHour, iMinute, iSec As Integer
    
    currentTimeDate = Now()
    iYear = Year(currentTimeDate)
    iMonth = Month(currentTimeDate)
    iDay = Day(currentTimeDate)
    iHour = Hour(currentTimeDate)
    iMinute = Minute(currentTimeDate)
    iSec = Second(currentTimeDate)
    FileName = Format(currentTimeDate, "yymmdd") _
             + Format(currentTimeDate, "hhmmss") + ".bmp"
End Function
'
' Этот макрос на входе получает диапазон ячеек листа
' Excel и создает по ним картинку - файл BMP по цветам
' ячеек. Формат файла BMP 24 бита, несжатый.
'
Sub subCellsToBMP(rngPicture As Range)
    Dim i As Long, j As Long, k As Long, l As Long
'
    Dim bmpFile As typBITMAPFILE
    Dim lngRowSize As Long
    Dim lngPixelArraySize As Long
    Dim lngFileSize As Long
'
    Dim bytRed As Integer, bytGreen As Integer, bytBlue As Integer
    Dim lngRGBColor() As Long
'
    Dim strBMP As String
'
' Сначала проверим на допустимый размер картинки - есть некоторые
' разумные ограничения
'
    If (rngPicture Is Nothing) Then Exit Sub
    If (rngPicture.Cells.Count < 4) Then
        MsgBox "Tried to export a BMP with less than 4 pixels!", _
        vbOKOnly + vbCritical, "BMP Export Error"
        Exit Sub
    End If
'
' Создание данных BMP, основываясь на выбранных ячейках.
'
    With bmpFile
' BMP Header
        With .bmfh
            .strType = "BM"      ' Базовый тип файла BMP
            .lngSize = 0         ' Определим позже (размер в байтах)
            .intRes1 = 0         ' Установлено в 0
            .intRes2 = 0         ' Установлено в 0
            .lngOffset = 54      ' Место, откуда начинается растр bitmap
        End With
' DIB Header
        With .bmfi
            .lngSize = 40        ' Это версия Version 3 BMP
            ' Количество пикселей по ширине:
            .lngWidth = rngPicture.Columns.Count
            ' Количество пикселей по высоте:
            .lngHeight = rngPicture.Rows.Count
            .intPlanes = 1       ' 1 слой
            .intBits = 24        ' 24 бита на точку (RGB)
            .lngCompression = 0  ' Без сжатия
            .lngImageSize = 0    ' Может быть установлено в 0
            .lngxResolution = 0  ' Установлено в 0
            .lngyResolution = 0  ' Установлено в 0
            .lngColorCount = 0   ' Установлено в 0 (нет цветовой палитры)
            .lngImportantColors = 0 ' Установлено в 0
        End With
        ' Размер 32-битного массива растра в байтах (нужно обеспечить
        ' выравнивание массива по 32 битной границе!).
        'Здесь была ошибка, на самом деле нужно использовать округление сверху:
        'lngRowSize = Round(.bmfi.intBits * .bmfi.lngWidth / 32) * 4
        'Начиная с версии Excel 2010 для выравнивания можно использовать это:
        'lngRowSize = WorksheetFunction.Ceiling_Precise _
        ' ((.bmfi.intBits * .bmfi.lngWidth / 32) * 4)
        'В версии Excel 2003 надо так:
        Dim rounded, unrounded As Double
        unrounded = .bmfi.intBits * .bmfi.lngWidth / 32
        rounded = Round(.bmfi.intBits * .bmfi.lngWidth / 32)
        If rounded < unrounded Then
            lngRowSize = (rounded + 1) * 4
        Else
            lngRowSize = rounded * 4
        End If
        lngPixelArraySize = lngRowSize * .bmfi.lngHeight
        ' Общее количество байт для сохранения выровненного массива пикселей
        ReDim .bmbits(lngPixelArraySize)
'
' Чтение данных цвета из ячеек (если цвета нет, то считается что
' это белый). Сканирование начинается снизу и продолжается вверх.
' Необходимо выравнивание каждой строки по границе 4 байта.
' ПРИМЕЧАНИЕ: вместо чтения цветов Вы можете читать числа,
' и получать значение "bytBlue", "bytGreen", "bytRed" напрямую
' из этих чисел.
'
        k = 0
        ReDim lngRGBColor(rngPicture.Rows.Count, rngPicture.Columns.Count)
        ' Цикл по строкам:
        For j = rngPicture.Rows.Count To 1 Step -1
            ' Цикл по столбцам:
            For i = 1 To rngPicture.Columns.Count
                If (LongToRGB(rngPicture.Cells(j, i).Interior.Color, _
                    bytRed, bytGreen, bytBlue)) Then
                    k = k + 1
                    .bmbits(k) = bytBlue
                    k = k + 1
                    .bmbits(k) = bytGreen
                    k = k + 1
                    .bmbits(k) = bytRed
                Else
                    k = k + 1
                    .bmbits(k) = 255
                    k = k + 1
                    .bmbits(k) = 255
                    k = k + 1
                    .bmbits(k) = 255
                End If
            Next i ' Для каждого столбца...
            If (rngPicture.Columns.Count * .bmfi.intBits / 8 < lngRowSize) Then
                ' Добавим выравнивание, если это необходимо
                For l = rngPicture.Columns.Count * .bmfi.intBits / 8 + 1 To lngRowSize
                    k = k + 1
                    .bmbits(k) = 0
                Next l
            End If
        Next j ' Цикл по строкам, начиная снизу...
'
' Все структуры загружены. Вычисляется размер файла и
' в него сохраняются данные растра.
'
        .bmfh.lngSize = 14 + 40 + lngPixelArraySize
'
    End With ' Определение bmpFile
'
    'Присвоим имя файлу и полный путь
    strBMP = ThisWorkbook.Path & "\" & FileName()
'
    Open strBMP For Binary Access Write As 1 Len = 1
'
    Put 1, 1, bmpFile.bmfh
    Put 1, , bmpFile.bmfi
    Put 1, , bmpFile.bmbits
'
    Close
'
End Sub
'
' Преобразование числа long integer, представляющего цвет,
' в значения каналов red, green, blue.
'
Public Function LongToRGB(theColor As Long, _
                          iRed As Integer, _
                          iGreen As Integer, _
                          iBlue As Integer) As Boolean
'
    iRed = theColor Mod 256                 'канал R
    iGreen = (theColor \ 256) Mod 256       'канал G
    iBlue = (theColor \ 256 \ 256) Mod 256  'канал B
'
    LongToRGB = True
End Function
'
' Эта подпрограмма тестирует макрос subCellsToBMP.
' Выделенный диапазон ячеек будет сохранен в файл
' как картинка BMP.
'
Sub Преобразовать_в_картинку()
Attribute Преобразовать_в_картинку.VB_Description = "Макрос записан 04.12.2014"
Attribute Преобразовать_в_картинку.VB_ProcData.VB_Invoke_Func = "b\n14"
    'Dim shtBMP As String имя листа, у меня не используется
    'Dim rngBMP As Range
    'shtBMP = "BMP Cells"
    'Set rngBMP = ThisWorkbook.Worksheets(shtBMP).Range("A1:AN11")
    Call subCellsToBMP(Selection)
End Sub

Sub Загрузить_картинку()
Attribute Загрузить_картинку.VB_ProcData.VB_Invoke_Func = "l\n14"
    Dim BmpFileName As String
    Dim bmpHeader As typHeader
    Dim bmpInfoHeader As typInfoHeader
    Dim nRow As Integer, nCol As Integer
    Dim nRowBytes As Long
    Dim bmpPixel As typePixel
    
    'Запуск диалога выбора файла:
    With Application.FileDialog(msoFileDialogOpen)
        .InitialFileName = Application.ActiveWorkbook.Path
        .AllowMultiSelect = False
        .Filters.Add "Bitmap", "*.bmp", 1
        If .Show = -1 Then
            BmpFileName = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    'Файл успешно выбран, откроем его:
    Open BmpFileName For Binary Access Read As 1 Len = 1
        Get 1, 1, bmpHeader
        'Проверка типа файла
        If bmpHeader.strType < > "BM" Then
            MsgBox "Not a bitmap file.", vbCritical, "Error"
            End
        End If
        'Проверка формата BMP
        Get 1, , bmpInfoHeader
        If bmpInfoHeader.intBits <> 24 Then
            MsgBox "Sorry, only 24-bits BMP files can be converted.", vbCritical, "Error"
            End
        End If
        If bmpInfoHeader.lngCompression <> 0 Then
            MsgBox "Sorry, only uncompressed BMP files can be converted.", vbCritical, "Error"
            End
        End If
        'Получение количества байт на строку, с дополнением до 4 байт
        nRowBytes = bmpInfoHeader.lngWidth * 3   '3 байта на точку
        If nRowBytes Mod 4 < > 0 Then
            nRowBytes = nRowBytes + (4 - nRowBytes Mod 4)
        End If
        'Чтение картинки попиксельно
        Dim x, y As Integer
        x = Selection.Column - 1
        y = Selection.Row - 1
        For nRow = 0 To bmpInfoHeader.lngHeight - 1
            For nCol = 0 To bmpInfoHeader.lngWidth - 1
                Get 1, bmpHeader.lngOffset + 1 + nRow * nRowBytes + nCol * 3, bmpPixel
                Cells(y + bmpInfoHeader.lngHeight - nRow, x + nCol + 1).Interior.Color _
                       = RGB(bmpPixel.r, bmpPixel.g, bmpPixel.b)
            Next
        Next
    Close
End Sub