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

Вход

Регистрация

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

 

= Мир MS Excel/Создание форм на листах под каждое уникальное значение - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание форм на листах под каждое уникальное значение (Макросы/Sub)
Создание форм на листах под каждое уникальное значение
Elvira66 Дата: Воскресенье, 16.07.2017, 12:09 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 60
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день!
Помоги написать макрос, приложила файл с примером.
Нужен макрос, который будет просматривать таблицу: для каждого уникального значения создавать лист. И на каждом листе должен формироваться форма такая как на вкладке пример.
К сообщению приложен файл: 3309362.xlsx(11Kb)
 
Ответить
СообщениеДобрый день!
Помоги написать макрос, приложила файл с примером.
Нужен макрос, который будет просматривать таблицу: для каждого уникального значения создавать лист. И на каждом листе должен формироваться форма такая как на вкладке пример.

Автор - Elvira66
Дата добавления - 16.07.2017 в 12:09
Udik Дата: Воскресенье, 16.07.2017, 14:12 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1586
Репутация: 191 ±
Замечаний: 0% ±

Excel 2016 х 64
Такой вариант

[vba]
Код

Option Explicit

Public Sub main()
Dim oDict As Object, unoRec As Variant
Dim i As Long, rowLast&, j&
Dim arrStr

    With ThisWorkbook.ActiveSheet
        rowLast = .Cells(Rows.Count, 1).End(xlUp).Row
        Set oDict = CreateObject("Scripting.Dictionary")
        oDict.CompareMode = 1
        
        For i = 2 To rowLast
            If Not oDict.exists(.Cells(i, 1).Text) Then
                oDict(.Cells(i, 1).Text) = Application.Trim(.Cells(i, 3).Value & " " & .Cells(i, 4).Value & "|")
            Else
                oDict(.Cells(i, 1).Text) = oDict(.Cells(i, 1).Text) & Application.Trim(.Cells(i, 3).Value & " " & .Cells(i, 4).Value & "|")

            End If
        Next i
    End With
    
    i = 0
    For Each unoRec In oDict.keys
    
        If Not SheetExists(Str(i + 1)) Then
            ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Worksheets.Count)).Name = Str(i + 1)
        End If
        
        With ThisWorkbook.Worksheets(Str(i + 1))
            .Range("A1:F50").Clear
            .Cells(2, 6).Value = unoRec
            .Cells(7, 3).Value = "Информирование."
            .Cells(9, 1).Value = "Уважаемый " & unoRec & ", ваша продуктовая корзина сотоит из: "
           
            arrStr = Split(oDict(unoRec), "|")
            
            For j = 0 To UBound(arrStr) - 1
                 .Cells(10 + j, 1).Value = arrStr(j)
            Next j
        End With
        i = i + 1
    Next
End Sub

''===

Function SheetExists(SheetName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Sheets(SheetName) Is Nothing
End Function

[/vba]
К сообщению приложен файл: 9934284.xlsm(25Kb)


вот вам барабан
яд 41001231307558 wm R419131876897
udik1968@gmail.com
 
Ответить
СообщениеТакой вариант

[vba]
Код

Option Explicit

Public Sub main()
Dim oDict As Object, unoRec As Variant
Dim i As Long, rowLast&, j&
Dim arrStr

    With ThisWorkbook.ActiveSheet
        rowLast = .Cells(Rows.Count, 1).End(xlUp).Row
        Set oDict = CreateObject("Scripting.Dictionary")
        oDict.CompareMode = 1
        
        For i = 2 To rowLast
            If Not oDict.exists(.Cells(i, 1).Text) Then
                oDict(.Cells(i, 1).Text) = Application.Trim(.Cells(i, 3).Value & " " & .Cells(i, 4).Value & "|")
            Else
                oDict(.Cells(i, 1).Text) = oDict(.Cells(i, 1).Text) & Application.Trim(.Cells(i, 3).Value & " " & .Cells(i, 4).Value & "|")

            End If
        Next i
    End With
    
    i = 0
    For Each unoRec In oDict.keys
    
        If Not SheetExists(Str(i + 1)) Then
            ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Worksheets.Count)).Name = Str(i + 1)
        End If
        
        With ThisWorkbook.Worksheets(Str(i + 1))
            .Range("A1:F50").Clear
            .Cells(2, 6).Value = unoRec
            .Cells(7, 3).Value = "Информирование."
            .Cells(9, 1).Value = "Уважаемый " & unoRec & ", ваша продуктовая корзина сотоит из: "
           
            arrStr = Split(oDict(unoRec), "|")
            
            For j = 0 To UBound(arrStr) - 1
                 .Cells(10 + j, 1).Value = arrStr(j)
            Next j
        End With
        i = i + 1
    Next
End Sub

''===

Function SheetExists(SheetName As String) As Boolean
    On Error Resume Next
    SheetExists = Not Sheets(SheetName) Is Nothing
End Function

[/vba]

Автор - Udik
Дата добавления - 16.07.2017 в 14:12
Elvira66 Дата: Воскресенье, 16.07.2017, 14:53 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 60
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Задача решена! Спасибо! hands
 
Ответить
СообщениеЗадача решена! Спасибо! hands

Автор - Elvira66
Дата добавления - 16.07.2017 в 14:53
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание форм на листах под каждое уникальное значение (Макросы/Sub)
Страница 1 из 11
Поиск:

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