Elvira66
Дата: Воскресенье, 16.07.2017, 12:09 |
Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 117
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
Добрый день! Помоги написать макрос, приложила файл с примером. Нужен макрос, который будет просматривать таблицу: для каждого уникального значения создавать лист. И на каждом листе должен формироваться форма такая как на вкладке пример.
Добрый день! Помоги написать макрос, приложила файл с примером. Нужен макрос, который будет просматривать таблицу: для каждого уникального значения создавать лист. И на каждом листе должен формироваться форма такая как на вкладке пример. Elvira66
Ответить
Сообщение Добрый день! Помоги написать макрос, приложила файл с примером. Нужен макрос, который будет просматривать таблицу: для каждого уникального значения создавать лист. И на каждом листе должен формироваться форма такая как на вкладке пример. Автор - Elvira66 Дата добавления - 16.07.2017 в 12:09
Udik
Дата: Воскресенье, 16.07.2017, 14:12 |
Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 1588
Репутация:
192
±
Замечаний:
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]
Такой вариант [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
вот вам барабан яд 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
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 117
Репутация:
0
±
Замечаний:
0% ±
Excel 2010
Задача решена! Спасибо!
Ответить
Сообщение Задача решена! Спасибо! Автор - Elvira66 Дата добавления - 16.07.2017 в 14:53