ВСТАВКА ФОТО В ЛИСТ EXCEL С ПОМОЩЬЮ МАКРОСА (НУЖНА ПОМОЩЬ!)

[Menshikov]

Добрый день, уважаемые эксперты!
Очень нужна Ваша помощь в создании макроса.
По роду занятий, мне постоянно приходиться вставлять картинки JPG в лист Excel по 100-200 штук в день, занятие крайне трудоемкое, есть ли возможность его упростить с помощью макроса.
Пример:
1. Лист Excel со столбцами: № п.п., артикул, наименование, цена, фото. (пример приложен к теме)
Ширина столбца фото 248 пискел, высота всех сток 165 пиксел, именно это и есть размер необходимого изображения в столбце фото, приходиться вставлять по одной фотографии и подгонять ее по размерам, потом сжимать, чтобы вес файла уменьшить, занятие безумное и занимает очень много времени.
Есть одна постоянная название каждой фотографии, соответствует номеру артикула напротив ячейки, где она должна находиться, возможно ли автоматизировать этот процесс с помощью макроса, я конечно не силен в этой теме, но вот как мне это видится, к примеру я создал лист, вставил все данные (№, артикул, наименование, цена), создал столбик фото растянул все столбы и стоки до необходимого размера и «волшебство» с помощью макроса из общей папки со всеми фото на рабочем столе я втягиваю фотографии в соответствии с их названием, т.е. в стоку где артикул равен имени фото и возможно ли чтобы фотографии сразу уменьшались до размера ячейки????
ГУРУ ПРОГРАМИРОВАНИЕ – ПОМОГИТЕ!!!!!

[airyashov]

незнаю с какой системой вы работайте, но такое довольно просто написать на 1с 8,а затем сохранить в лист excel

[Menshikov]

незнаю с какой системой вы работайте, но такое довольно просто написать на 1с 8,а затем сохранить в лист excel

Добрый день, тема закрыта.
Мне уже помогли с написание макроса.
Спасибо за внимание.

[airyashov]

а не можите выложить здесь посмотреть сколько приходилось работать, с картинками в excel не очень удобно.

[Menshikov]

а не можите выложить здесь посмотреть сколько приходилось работать, с картинками в excel не очень удобно.

Добрый день, а как его выложить, управление вложениями не пускает файл к прикреплению, вот макрос:

Sub Vstavka_Kartinok()
Sheets("Лист1").Select
x = 1
Range("A1").Select
While Sheets("Лист1").Cells(x, 2).Text <> ""
x = x + 1
Wend
x = x - 1
For i = 2 To x
kartinka = Sheets("Лист1").Cells(i, 2).Value
Range("E" & CStr(i)).Select
ActiveSheet.Pictures.Insert("C:\Documents and Settings\R_Menshikov\Рабочий стол\Photo\" & CStr(kartinka) & ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 152.2
Selection.ShapeRange.Width = 183.75
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
Next i
MsgBox ("Фото успешно вставлены")
End Sub

Есть одна проблема, он работает в Excel 2003, в Excel 2007 работает не корректно, может кто может помочь с адаптацией, макрос должен вставлять каждую картинку напротив ячейки с ее цифровым значением, в 2007 он сваливает их все в одну кучу.
Помогите если можете.

[airyashov]

спасибо, так и думал через select, попробую на 2007
--------------------------------------------------------------------------------
Добавлено сообщение
--------------------------------------------------------------------------------
для 2007
попробуйте подобрать параметры

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

Sub Vstavka_Kartinok()
Sheets("Ëèñò1").Select
x = 1
Range("A1").Select
While Sheets("Ëèñò1").Cells(x, 2).Text <> ""
x = x + 1
Wend
x = x - 1
For i = 2 To x
kartinka = Sheets("Ëèñò1").Cells(i, 2).Value
Range("E" & CStr(i)).Select
Dim SR As ShapeRange

ActiveSheet.Pictures.Insert("C:\1\" & CStr(kartinka) & ".jpg").Select
'Set SR = Selection.ShapeRange

[B]Selection.ShapeRange.Left = 200
Selection.ShapeRange.Top = 100 * (i - 2)[/B]

Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 152.2
Selection.ShapeRange.Width = 183.75
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
Next i
MsgBox ("Ôîòî óñïåøíî âñòàâëåíû")
End Sub

Sub InsertShapeNode()
    ActiveSheet.Shapes(1).Select
    With Selection.ShapeRange
        If .Type = msoFreeform Then
            .Nodes.Insert _
                Index:=3, SegmentType:=msoSegmentCurve, _
                EditingType:=msoEditingSymmetric, X1:=35, Y1:=100
            .Fill.ForeColor.RGB = RGB(0, 0, 200)
            .Fill.Visible = msoTrue
        Else
            MsgBox "This shape is not a Freeform object."
        End If
    End With
End Sub

[Menshikov]

спасибо, так и думал через select, попробую на 2007
--------------------------------------------------------------------------------
Добавлено сообщение
--------------------------------------------------------------------------------
для 2007
попробуйте подобрать параметры

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

Sub Vstavka_Kartinok()
Sheets("Ëèñò1").Select
x = 1
Range("A1").Select
While Sheets("Ëèñò1").Cells(x, 2).Text <> ""
x = x + 1
Wend
x = x - 1
For i = 2 To x
kartinka = Sheets("Ëèñò1").Cells(i, 2).Value
Range("E" & CStr(i)).Select
Dim SR As ShapeRange

ActiveSheet.Pictures.Insert("C:\1\" & CStr(kartinka) & ".jpg").Select
'Set SR = Selection.ShapeRange

[B]Selection.ShapeRange.Left = 200
Selection.ShapeRange.Top = 100 * (i - 2)[/B]

Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 152.2
Selection.ShapeRange.Width = 183.75
Selection.ShapeRange.Rotation = 0#
Selection.ShapeRange.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
Next i
MsgBox ("Ôîòî óñïåøíî âñòàâëåíû")
End Sub

Sub InsertShapeNode()
    ActiveSheet.Shapes(1).Select
    With Selection.ShapeRange
        If .Type = msoFreeform Then
            .Nodes.Insert _
                Index:=3, SegmentType:=msoSegmentCurve, _
                EditingType:=msoEditingSymmetric, X1:=35, Y1:=100
            .Fill.ForeColor.RGB = RGB(0, 0, 200)
            .Fill.Visible = msoTrue
        Else
            MsgBox "This shape is not a Freeform object."
        End If
    End With
End Sub

Спасибо за труды, но я не так силен в макросах, какие параметры необходимо подобрать?
Что необходимо прописать в макросе.
У Вас работает макрос в Excel 2007?

[airyashov]

вот эти, можите кинуть файл excel с установленными параметрами хотябы для 1 ячейки, т.е. полностью 1 строка сформатированная как нужно
Selection.ShapeRange.Left =
Selection.ShapeRange.Top =

[Menshikov]

вот эти, можите кинуть файл excel с установленными параметрами хотябы для 1 ячейки, т.е. полностью 1 строка сформатированная как нужно
Selection.ShapeRange.Left =
Selection.ShapeRange.Top =

Добрый вечер, конечно я могу выслать файл, но файлы Excel к сообщению не прикрепляются, сообщите вашу электронную почту.

[airyashov]

почта в подписи