Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

= Мир MS Excel/Заполнение диапазона - фигурами в несколько рядов. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Заполнение диапазона - фигурами в несколько рядов. (Макросы/Sub)
Заполнение диапазона - фигурами в несколько рядов.
димитрий2 Дата: Среда, 26.12.2018, 22:14 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Доброго времени суток.
Столкнулся с проблемой в экселе.
Суть такая:
В диапазоне R3:S6 находится кружок
В диапазоне E8:H17 изначально пусто.
И вот нужно как-то макросом - переносить копии кружка из R3:S6 в E8:H17 - по одной копии за срабатывание.

Но диапазон E8:H17 должен заполнятся с верхнего левого угла - в ряды - до левой границы диапазона, а затем заполнение идет "с новой строки".
Это непросто словами объяснить, но в файле - я показал какой порядок заполнения.

Как только диапазон заполнится - макрос при щелчке - должен бездействовать (поскольку в диапазоне больше места свободного не осталось).

Как провести подобное заполнение диапазона E8:H17 - копиями фигур из R3:S6 ?
К сообщению приложен файл: 0031846.xls(51.5 Kb)
 
Ответить
СообщениеДоброго времени суток.
Столкнулся с проблемой в экселе.
Суть такая:
В диапазоне R3:S6 находится кружок
В диапазоне E8:H17 изначально пусто.
И вот нужно как-то макросом - переносить копии кружка из R3:S6 в E8:H17 - по одной копии за срабатывание.

Но диапазон E8:H17 должен заполнятся с верхнего левого угла - в ряды - до левой границы диапазона, а затем заполнение идет "с новой строки".
Это непросто словами объяснить, но в файле - я показал какой порядок заполнения.

Как только диапазон заполнится - макрос при щелчке - должен бездействовать (поскольку в диапазоне больше места свободного не осталось).

Как провести подобное заполнение диапазона E8:H17 - копиями фигур из R3:S6 ?

Автор - димитрий2
Дата добавления - 26.12.2018 в 22:14
Roman777 Дата: Четверг, 27.12.2018, 11:49 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 960
Репутация: 123 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
димитрий2, Попробуйте так:
[vba]
Код
Sub Filling()
    Dim r0, r
    Dim shp0 As Shape, shp As Shape
    Dim flg1 As Boolean
    Dim Lx As Single, Ly As Single, curY#, curX#, X0#
    Dim w#, h#, L#, T#
    Dim LxBorder#, LyBorder#
    Dim deltX#, deltY#
    flg1 = False
    deltX = 6.5 'промежуточные расстояния по Х
    deltY = 5.5 'промежуточные расстояния по Y
    With ActiveSheet
        Set r0 = .Range("R3:S6")
        Set r = .Range("E8:H17")
        With .Cells(r.Rows(1).Row, 1)
            curY = deltY + .Top
        End With
        With .Cells(1, r.Columns(1).Column)
            curX = deltX + .Left
        End With
        With .Cells(r.Rows(r.Rows.Count).Row, 1)
            LyBorder = deltY + .Top + .Height
        End With
        With .Cells(1, r.Columns(r.Columns.Count).Column)
            LxBorder = deltX + .Left + .Width
        End With
        Lx = curX + deltX
        X0 = Lx
        Ly = curY + deltY
        For Each shp In .Shapes
            If Not Intersect(r0, .Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing And Not flg Then
                Set shp0 = shp
                flg1 = True
            End If
            If Not Intersect(r, .Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then
                w = shp.Width
                h = shp.Height
                L = shp.Left
                T = shp.Top
                curY = T
                If Ly <= curY Then
                    If Ly < curY Then
                        Ly = curY
                        Lx = X0
                    End If
                    curX = w + L
                    If Lx < curX Then
                        Lx = curX + deltX
                    End If
                End If
            End If
        Next shp
        curX = Lx
        If curX <= LxBorder - w Then
            curY = Ly
        Else
            curX = X0
            curY = Ly + h + deltY
        End If
        If curY <= LyBorder - h - deltY Then
            Set shp = shp0.Duplicate
            shp.Left = curX
            shp.Top = curY
        End If
    End With
End Sub
[/vba]
[p.s.]Чутка подправил. Изменения ни на что не влияют, кроме моей самооценки.[/p.s.]


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

Сообщение отредактировал Roman777 - Четверг, 27.12.2018, 15:32
 
Ответить
Сообщениедимитрий2, Попробуйте так:
[vba]
Код
Sub Filling()
    Dim r0, r
    Dim shp0 As Shape, shp As Shape
    Dim flg1 As Boolean
    Dim Lx As Single, Ly As Single, curY#, curX#, X0#
    Dim w#, h#, L#, T#
    Dim LxBorder#, LyBorder#
    Dim deltX#, deltY#
    flg1 = False
    deltX = 6.5 'промежуточные расстояния по Х
    deltY = 5.5 'промежуточные расстояния по Y
    With ActiveSheet
        Set r0 = .Range("R3:S6")
        Set r = .Range("E8:H17")
        With .Cells(r.Rows(1).Row, 1)
            curY = deltY + .Top
        End With
        With .Cells(1, r.Columns(1).Column)
            curX = deltX + .Left
        End With
        With .Cells(r.Rows(r.Rows.Count).Row, 1)
            LyBorder = deltY + .Top + .Height
        End With
        With .Cells(1, r.Columns(r.Columns.Count).Column)
            LxBorder = deltX + .Left + .Width
        End With
        Lx = curX + deltX
        X0 = Lx
        Ly = curY + deltY
        For Each shp In .Shapes
            If Not Intersect(r0, .Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing And Not flg Then
                Set shp0 = shp
                flg1 = True
            End If
            If Not Intersect(r, .Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then
                w = shp.Width
                h = shp.Height
                L = shp.Left
                T = shp.Top
                curY = T
                If Ly <= curY Then
                    If Ly < curY Then
                        Ly = curY
                        Lx = X0
                    End If
                    curX = w + L
                    If Lx < curX Then
                        Lx = curX + deltX
                    End If
                End If
            End If
        Next shp
        curX = Lx
        If curX <= LxBorder - w Then
            curY = Ly
        Else
            curX = X0
            curY = Ly + h + deltY
        End If
        If curY <= LyBorder - h - deltY Then
            Set shp = shp0.Duplicate
            shp.Left = curX
            shp.Top = curY
        End If
    End With
End Sub
[/vba]
[p.s.]Чутка подправил. Изменения ни на что не влияют, кроме моей самооценки.[/p.s.]

Автор - Roman777
Дата добавления - 27.12.2018 в 11:49
димитрий2 Дата: Четверг, 27.12.2018, 12:02 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Roman777, огромное спасибо за ответ.
 
Ответить
СообщениеRoman777, огромное спасибо за ответ.

Автор - димитрий2
Дата добавления - 27.12.2018 в 12:02
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Заполнение диапазона - фигурами в несколько рядов. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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