Расстановка картинок в ряд - по вертикали - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Расстановка картинок в ряд - по вертикали - Мир MS Excel

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Расстановка картинок в ряд - по вертикали (Макросы/Sub)

Расстановка картинок в ряд - по вертикали

Дата: Вторник, 24.10.2017, 11:05 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Доброе утро, форумчане.
Помогите решить проблему.

В папке с файлом эксель лежат несколько пронумерованных файлов jpg.
Как макросом - расставить их по вертикали (в соответствии с номерами файлов - по возрастанию) - на лист, начиная от ячейки C3 ?

К сообщению приложен файл: 943563.rar (35.5 Kb)

Ответить

Дата: Четверг, 26.10.2017, 22:26 | Сообщение № 2

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

perven, Сортировка, наверное, слабовата)))
Но примерно можно так (Это с расчётом, что все файлы jpg и с именем-цифрой):
[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO, pic
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)
offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            If fl.Type = "Файл ""JPG""" Then
                k = k + 1
                ReDim Preserve sInfo(2, k)
                sInfo(1, k) = Left(fl.ShortName, Len(fl.ShortName) - Len(".jpg"))
                sInfo(2, k) = fl.Path
            End If
         Next fl
    End With
    Call Sortir(sInfo)
    For i = 1 To UBound(sInfo, 2)
        h = Range(r, r.Offset(offsetLeight)).Height
        r.Select
        Set pic = ActiveSheet.Pictures.Insert(sInfo(2, i))
'                pic.Width = pic.Height / h
        pic.Height = h
        Set r = r.Offset(offsetLeight + 1)
    Next i
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

[/vba]

perven, Сортировка, наверное, слабовата)))
Но примерно можно так (Это с расчётом, что все файлы jpg и с именем-цифрой):
[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO, pic
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)
offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            If fl.Type = "Файл ""JPG""" Then
                k = k + 1
                ReDim Preserve sInfo(2, k)
                sInfo(1, k) = Left(fl.ShortName, Len(fl.ShortName) - Len(".jpg"))
                sInfo(2, k) = fl.Path
            End If
         Next fl
    End With
    Call Sortir(sInfo)
    For i = 1 To UBound(sInfo, 2)
        h = Range(r, r.Offset(offsetLeight)).Height
        r.Select
        Set pic = ActiveSheet.Pictures.Insert(sInfo(2, i))
'                pic.Width = pic.Height / h
        pic.Height = h
        Set r = r.Offset(offsetLeight + 1)
    Next i
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

К сообщению приложен файл: 943563.xls (80.5 Kb)

Много чего не знаю!!!!

Ответить

Сообщениеperven, Сортировка, наверное, слабовата)))
Но примерно можно так (Это с расчётом, что все файлы jpg и с именем-цифрой):
[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO, pic
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)
offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            If fl.Type = "Файл ""JPG""" Then
                k = k + 1
                ReDim Preserve sInfo(2, k)
                sInfo(1, k) = Left(fl.ShortName, Len(fl.ShortName) - Len(".jpg"))
                sInfo(2, k) = fl.Path
            End If
         Next fl
    End With
    Call Sortir(sInfo)
    For i = 1 To UBound(sInfo, 2)
        h = Range(r, r.Offset(offsetLeight)).Height
        r.Select
        Set pic = ActiveSheet.Pictures.Insert(sInfo(2, i))
'                pic.Width = pic.Height / h
        pic.Height = h
        Set r = r.Offset(offsetLeight + 1)
    Next i
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

[/vba]

Автор - Roman777
Дата добавления - 26.10.2017 в 22:26

Дата: Пятница, 27.10.2017, 01:06 | Сообщение № 3

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Roman777, не работает.
Выдает ошибку при запуске - "Run-time error `13`: Type mismatch"

Ответить

Дата: Пятница, 27.10.2017, 13:04 | Сообщение № 4

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

perven, Скажите, пожалуйста, а на какой строчке ошибка, если дебаг нажать?
Судя по всему неверные данные получает код... У вас все файлы jpg и имя имеют цифрой?
ещё попробуйте такой макрос (но функцию сортировки оставьте прежней):
[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO, pic
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)
offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            If fl.Type = "Файл ""JPG""" Then
                k = k + 1
                ReDim Preserve sInfo(2, k)
                sInfo(1, k) = Left(fl.ShortName, Len(fl.ShortName) - Len(".jpg"))
                sInfo(2, k) = fl.Path
            End If
         Next fl
    End With
    Call Sortir(sInfo)
    For i = 1 To UBound(sInfo, 2)
        h = Range(r, r.Offset(offsetLeight)).Height
        r.Select
        Set pic = r.Parent.Shapes.AddPicture(sInfo(2, i), False, True, r.Left, r.Top, -1, -1)
'        Set pic = r.Parent.Pictures.Insert(sInfo(2, i))
'        pic.Width = pic.Height / h
        pic.Height = h
        Set r = r.Offset(offsetLeight + 1)
    Next i
End With
End Sub

[/vba]

Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Пятница, 27.10.2017, 14:34

Ответить

Сообщениеperven, Скажите, пожалуйста, а на какой строчке ошибка, если дебаг нажать?
Судя по всему неверные данные получает код... У вас все файлы jpg и имя имеют цифрой?
ещё попробуйте такой макрос (но функцию сортировки оставьте прежней):
[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO, pic
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)
offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            If fl.Type = "Файл ""JPG""" Then
                k = k + 1
                ReDim Preserve sInfo(2, k)
                sInfo(1, k) = Left(fl.ShortName, Len(fl.ShortName) - Len(".jpg"))
                sInfo(2, k) = fl.Path
            End If
         Next fl
    End With
    Call Sortir(sInfo)
    For i = 1 To UBound(sInfo, 2)
        h = Range(r, r.Offset(offsetLeight)).Height
        r.Select
        Set pic = r.Parent.Shapes.AddPicture(sInfo(2, i), False, True, r.Left, r.Top, -1, -1)
'        Set pic = r.Parent.Pictures.Insert(sInfo(2, i))
'        pic.Width = pic.Height / h
        pic.Height = h
        Set r = r.Offset(offsetLeight + 1)
    Next i
End With
End Sub

[/vba]

Автор - Roman777
Дата добавления - 27.10.2017 в 13:04

Дата: Суббота, 28.10.2017, 08:37 | Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Roman777, тоже не работает.
Выдает ту же ошибку.

Подсвечивает строчку кода:
[vba]

Код

If CLng(m(1, i)) > CLng(m(1, j)) Then

[/vba]
Это относится к Function Sortir(ByRef m As Variant)

Сообщение отредактировал perven - Суббота, 28.10.2017, 08:39

Ответить

Дата: Суббота, 28.10.2017, 11:42 | Сообщение № 6

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

perven, вы хотите порядок по именам файлов?
Ваши файлы имеют название "Name.jpg", где Name является числом? Покажите реальные наименования.

Много чего не знаю!!!!

Ответить

Дата: Суббота, 28.10.2017, 12:44 | Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Roman777, наименования моих файлов - в архиве в первом сообщении.
1.jpg
2.jpg
3.jpg
4.jpg

Ответить

Дата: Суббота, 28.10.2017, 13:11 | Сообщение № 8

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

perven, Тогда попробуйте поместить файлы jpg в одну папку с файлом - экселем.
Немного подкорректировал, на случай отсутствия файлов в том же каталоге, что и книга (и отсёк картинки с нечисловыми именами).

[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO, pic
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
Dim flgControl As Boolean
Dim namefl As String
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)

offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            If fl.Type = "Файл ""JPG""" Then
                namefl = Left(fl.ShortName, Len(fl.ShortName) - Len(".jpg"))
                If IsNumeric(namefl) Then
                    k = k + 1
                    ReDim Preserve sInfo(2, k)
                    sInfo(1, k) = namefl
                    sInfo(2, k) = fl.Path
                End If
            End If
         Next fl
    End With
    If k > 0 Then
        Call Sortir(sInfo)
        For i = 1 To UBound(sInfo, 2)
            h = Range(r, r.Offset(offsetLeight)).Height
            r.Select
            Set pic = r.Parent.Shapes.AddPicture(sInfo(2, i), False, True, r.Left, r.Top, -1, -1)
'            Set pic = r.Parent.Pictures.Insert(sInfo(2, i))
'            pic.Width = pic.Height / h
            pic.Height = h
            Set r = r.Offset(offsetLeight + 1)
        Next i
    Else
        MsgBox "Файлов формата " & """JPG""" & " в папке с книгой не найдено", 48
    End If
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

[/vba]

perven, Тогда попробуйте поместить файлы jpg в одну папку с файлом - экселем.
Немного подкорректировал, на случай отсутствия файлов в том же каталоге, что и книга (и отсёк картинки с нечисловыми именами).

[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO, pic
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
Dim flgControl As Boolean
Dim namefl As String
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)

offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            If fl.Type = "Файл ""JPG""" Then
                namefl = Left(fl.ShortName, Len(fl.ShortName) - Len(".jpg"))
                If IsNumeric(namefl) Then
                    k = k + 1
                    ReDim Preserve sInfo(2, k)
                    sInfo(1, k) = namefl
                    sInfo(2, k) = fl.Path
                End If
            End If
         Next fl
    End With
    If k > 0 Then
        Call Sortir(sInfo)
        For i = 1 To UBound(sInfo, 2)
            h = Range(r, r.Offset(offsetLeight)).Height
            r.Select
            Set pic = r.Parent.Shapes.AddPicture(sInfo(2, i), False, True, r.Left, r.Top, -1, -1)
'            Set pic = r.Parent.Pictures.Insert(sInfo(2, i))
'            pic.Width = pic.Height / h
            pic.Height = h
            Set r = r.Offset(offsetLeight + 1)
        Next i
    Else
        MsgBox "Файлов формата " & """JPG""" & " в папке с книгой не найдено", 48
    End If
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

[/vba]

Много чего не знаю!!!!

Ответить

Сообщениеperven, Тогда попробуйте поместить файлы jpg в одну папку с файлом - экселем.
Немного подкорректировал, на случай отсутствия файлов в том же каталоге, что и книга (и отсёк картинки с нечисловыми именами).

[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO, pic
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
Dim flgControl As Boolean
Dim namefl As String
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)

offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            If fl.Type = "Файл ""JPG""" Then
                namefl = Left(fl.ShortName, Len(fl.ShortName) - Len(".jpg"))
                If IsNumeric(namefl) Then
                    k = k + 1
                    ReDim Preserve sInfo(2, k)
                    sInfo(1, k) = namefl
                    sInfo(2, k) = fl.Path
                End If
            End If
         Next fl
    End With
    If k > 0 Then
        Call Sortir(sInfo)
        For i = 1 To UBound(sInfo, 2)
            h = Range(r, r.Offset(offsetLeight)).Height
            r.Select
            Set pic = r.Parent.Shapes.AddPicture(sInfo(2, i), False, True, r.Left, r.Top, -1, -1)
'            Set pic = r.Parent.Pictures.Insert(sInfo(2, i))
'            pic.Width = pic.Height / h
            pic.Height = h
            Set r = r.Offset(offsetLeight + 1)
        Next i
    Else
        MsgBox "Файлов формата " & """JPG""" & " в папке с книгой не найдено", 48
    End If
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

[/vba]

Автор - Roman777
Дата добавления - 28.10.2017 в 13:11

Дата: Воскресенье, 29.10.2017, 07:28 | Сообщение № 9

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Цитата Roman777, 28.10.2017 в 13:11, в сообщении № 8 ()

Тогда попробуйте поместить файлы jpg в одну папку с файлом - экселем.

Они вообще-то все время лежали в одной папке с файлом xls, как в архиве - в первом сообщении.

Последняя версия макроса - не работает.
Пишет - "Файлов формата "JPG" в папке с книгой не найдено".

Ответить

Дата: Воскресенье, 29.10.2017, 08:43 | Сообщение № 10

Группа: Админы

Ранг: Местный житель

Сообщений: 19603

Репутация: 4660 ±

Замечаний: ±

Excel 365 & Mac Excel

Попробовала запустить на Excel 2010 и 2013 (32), всё работает. И первый вариант тоже работал.

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Воскресенье, 29.10.2017, 09:58 | Сообщение № 11

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

perven, Хорошо, запустите, пожалуйста
Следующий макрос:
[vba]

Код

Sub InterToVertiKal()
Dim sPath As String
Dim FSO
Dim s$
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")

With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в папке с книгой не найдено", 48
            Exit Sub
        End If
        For Each fl In .Files
            s = s & Chr(13) & fl.Type
        Next fl
        Debug.Print s
    End With
End With
End Sub

[/vba]
у меня подозрения, что тип может иначе отображаться... что-то в МДСНе не нашёл информации...
После отработанного макроса в окне Immediate должна отобразиться информация о типе отображаемых в папке книги файлов.
Скопируйте, пожалуйста, сюда эту информацию.

Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Воскресенье, 29.10.2017, 09:58

Ответить

Дата: Воскресенье, 29.10.2017, 10:15 | Сообщение № 12

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Pelena, у меня Эксель2013x64

Ответить

Дата: Воскресенье, 29.10.2017, 10:18 | Сообщение № 13

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Roman777, последний макрос - не работает.

Ошибки не выдает.
Картинки в вертикальный ряд - тоже не расставляет.

Ответить

Дата: Воскресенье, 29.10.2017, 10:20 | Сообщение № 14

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

perven, у меня эксель 2013х64 дома тоже... работает отлично.
Последний макрос должен был написать в окно Immediate кой-чего, что я Вас попросил сюда скопировать)
Нажимаем Alt+F11.Появляется окно ВБА. если тут нет у Вас окошечка Immediate, зайдите в View, там включите отображение Immediate window.

Много чего не знаю!!!!

Сообщение отредактировал Roman777 - Воскресенье, 29.10.2017, 10:22

Ответить

Дата: Воскресенье, 29.10.2017, 11:38 | Сообщение № 15

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Roman777, в окошке Immediate - выдается вот такая запись:

Рисунок JPEG
Рисунок JPEG
Рисунок JPEG
Рисунок JPEG
Лист Microsoft Excel 97-2003

Ответить

Дата: Воскресенье, 29.10.2017, 12:41 | Сообщение № 16

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

perven, Как я и думал, наверное, от операционной системы зависит
Попробуйте так:

[vba]

Код

Sub InterToVertiKal_2()
Dim sPath As String
Dim FSO, pic
Dim a1 As Variant
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
Dim flgControl As Boolean
Dim namefl As String
Dim Type_ As String, ShortName_ As String
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)

offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            ShortName_ = fl.ShortName
            Type_ = UCase(Right(ShortName_, Len(ShortName_) - InStrRev(ShortName_, ".")))
            If Type_ = "JPG" Or Type_ = "JPEG" Then
                namefl = Left(ShortName_, Len(ShortName_) - (Len(Type_) + 1))
                If IsNumeric(namefl) Then
                    k = k + 1
                    ReDim Preserve sInfo(2, k)
                    sInfo(1, k) = namefl
                    sInfo(2, k) = fl.Path
                End If
            End If
         Next fl
    End With
    If k > 0 Then
        Call Sortir(sInfo)
        For i = 1 To UBound(sInfo, 2)
            h = Range(r, r.Offset(offsetLeight)).Height
            r.Select
            Set pic = r.Parent.Shapes.AddPicture(sInfo(2, i), False, True, r.Left, r.Top, -1, -1)
'            Set pic = r.Parent.Pictures.Insert(sInfo(2, i))
'            pic.Width = pic.Height / h
            pic.Height = h
            Set r = r.Offset(offsetLeight + 1)
        Next i
    Else
        MsgBox "Файлов формата " & """JPG""" & " в папке с книгой не найдено", 48
    End If
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

[/vba]

perven, Как я и думал, наверное, от операционной системы зависит
Попробуйте так:

[vba]

Код

Sub InterToVertiKal_2()
Dim sPath As String
Dim FSO, pic
Dim a1 As Variant
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
Dim flgControl As Boolean
Dim namefl As String
Dim Type_ As String, ShortName_ As String
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)

offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            ShortName_ = fl.ShortName
            Type_ = UCase(Right(ShortName_, Len(ShortName_) - InStrRev(ShortName_, ".")))
            If Type_ = "JPG" Or Type_ = "JPEG" Then
                namefl = Left(ShortName_, Len(ShortName_) - (Len(Type_) + 1))
                If IsNumeric(namefl) Then
                    k = k + 1
                    ReDim Preserve sInfo(2, k)
                    sInfo(1, k) = namefl
                    sInfo(2, k) = fl.Path
                End If
            End If
         Next fl
    End With
    If k > 0 Then
        Call Sortir(sInfo)
        For i = 1 To UBound(sInfo, 2)
            h = Range(r, r.Offset(offsetLeight)).Height
            r.Select
            Set pic = r.Parent.Shapes.AddPicture(sInfo(2, i), False, True, r.Left, r.Top, -1, -1)
'            Set pic = r.Parent.Pictures.Insert(sInfo(2, i))
'            pic.Width = pic.Height / h
            pic.Height = h
            Set r = r.Offset(offsetLeight + 1)
        Next i
    Else
        MsgBox "Файлов формата " & """JPG""" & " в папке с книгой не найдено", 48
    End If
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

[/vba]

Много чего не знаю!!!!

Ответить

Сообщениеperven, Как я и думал, наверное, от операционной системы зависит
Попробуйте так:

[vba]

Код

Sub InterToVertiKal_2()
Dim sPath As String
Dim FSO, pic
Dim a1 As Variant
Dim sInfo() As String, k As Long
Dim r As Range, offsetLeight As Integer, h As Double
Dim flgControl As Boolean
Dim namefl As String
Dim Type_ As String, ShortName_ As String
sPath = ThisWorkbook.Path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set r = Cells(4, 3)
ReDim sInfo(2, 1)

offsetLeight = 13 'отвечает за высоту рисунка. Если тут 13, то высота рисунка будет в 14 ячеек
With FSO
    With .GetFolder(sPath)
        If .Files.Count = 0 Then
            MsgBox "Файлов в папке с книгой не найдено", 48
            Exit Sub
        End If
         For Each fl In .Files
            ShortName_ = fl.ShortName
            Type_ = UCase(Right(ShortName_, Len(ShortName_) - InStrRev(ShortName_, ".")))
            If Type_ = "JPG" Or Type_ = "JPEG" Then
                namefl = Left(ShortName_, Len(ShortName_) - (Len(Type_) + 1))
                If IsNumeric(namefl) Then
                    k = k + 1
                    ReDim Preserve sInfo(2, k)
                    sInfo(1, k) = namefl
                    sInfo(2, k) = fl.Path
                End If
            End If
         Next fl
    End With
    If k > 0 Then
        Call Sortir(sInfo)
        For i = 1 To UBound(sInfo, 2)
            h = Range(r, r.Offset(offsetLeight)).Height
            r.Select
            Set pic = r.Parent.Shapes.AddPicture(sInfo(2, i), False, True, r.Left, r.Top, -1, -1)
'            Set pic = r.Parent.Pictures.Insert(sInfo(2, i))
'            pic.Width = pic.Height / h
            pic.Height = h
            Set r = r.Offset(offsetLeight + 1)
        Next i
    Else
        MsgBox "Файлов формата " & """JPG""" & " в папке с книгой не найдено", 48
    End If
End With
End Sub
Function Sortir(ByRef m As Variant) As Variant
Dim t1 As String, t2 As String
Dim leight As Long
    leight = UBound(m, 2)
    For i = 1 To leight
        For j = i To leight
            If CLng(m(1, i)) > CLng(m(1, j)) Then
                s1 = m(1, i)
                s2 = m(2, i)
                m(1, i) = m(1, j)
                m(2, i) = m(2, j)
                m(1, j) = s1
                m(2, j) = s2
                j = i
            End If
        Next j
    Next i
End Function

[/vba]

Автор - Roman777
Дата добавления - 29.10.2017 в 12:41

Дата: Понедельник, 30.10.2017, 02:07 | Сообщение № 17

Группа: Пользователи

Ранг: Участник

Сообщений: 67

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Roman777, теперь все заработало.
Спасибо.

Ответить

Расстановка картинок в ряд - по вертикали (Макросы/Sub)

Страница 1 из 1
1

© 2010-2026 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!