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

Вход

Регистрация

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

 

= Мир MS Excel/Распределение данных по листам книги с помощью макроса - Страница 2 - Мир MS Excel

Старая форма входа
  • Страница 2 из 2
  • «
  • 1
  • 2
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Распределение данных по листам книги с помощью макроса (Формулы/Formulas, Макросы/Macros)
Распределение данных по листам книги с помощью макроса
Kuzmich Дата: Вторник, 19.06.2018, 15:39 | Сообщение № 21
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация: 156 ±
Замечаний: 0% ±

Excel 2003
Vselennaya, у вас в каждом выложенном файле все время разные данные: то
Итого по хозяйственному
Итого по обычному, а в последнем файле уже
ИТОГО по ло-ву
Вы не могли бы прийти к единой терминологии.
Дальше, если у вас номера могут быть с начальным нулем, например 0738А, то вы говорили,
что в имени листа этого нуля не будет, но я вижу, что есть лист 0738. (Я полагал, что будет 738)
На листах с именем номера вагона шапка B14:N14 уже существует? Почему-то на некоторых листах ее нет.
И, главное, не могли бы вы отвечать быстрее на мои вопросы.
 
Ответить
СообщениеVselennaya, у вас в каждом выложенном файле все время разные данные: то
Итого по хозяйственному
Итого по обычному, а в последнем файле уже
ИТОГО по ло-ву
Вы не могли бы прийти к единой терминологии.
Дальше, если у вас номера могут быть с начальным нулем, например 0738А, то вы говорили,
что в имени листа этого нуля не будет, но я вижу, что есть лист 0738. (Я полагал, что будет 738)
На листах с именем номера вагона шапка B14:N14 уже существует? Почему-то на некоторых листах ее нет.
И, главное, не могли бы вы отвечать быстрее на мои вопросы.

Автор - Kuzmich
Дата добавления - 19.06.2018 в 15:39
Vselennaya Дата: Вторник, 19.06.2018, 15:59 | Сообщение № 22
Группа: Пользователи
Ранг: Новичок
Сообщений: 18
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Kuzmich, нет там шапки, где не проставляет данные. Естественно, я и шапки расставлю. Там сотни номеров будет и вкладок в итоге. С нулями это назвала листы, чтобы посмотреть расставит макрос данные или нет. Увы не расставил. По поводу формулировки Итого, простите не знала, что имеет значение. ИТОГО по ло-ву должно быть. Как в последнем.
Стараюсь отвечать как можно быстрее. Очень отвлекают другими рабочими вопросами. Извините
 
Ответить
СообщениеKuzmich, нет там шапки, где не проставляет данные. Естественно, я и шапки расставлю. Там сотни номеров будет и вкладок в итоге. С нулями это назвала листы, чтобы посмотреть расставит макрос данные или нет. Увы не расставил. По поводу формулировки Итого, простите не знала, что имеет значение. ИТОГО по ло-ву должно быть. Как в последнем.
Стараюсь отвечать как можно быстрее. Очень отвлекают другими рабочими вопросами. Извините

Автор - Vselennaya
Дата добавления - 19.06.2018 в 15:59
Kuzmich Дата: Вторник, 19.06.2018, 16:23 | Сообщение № 23
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация: 156 ±
Замечаний: 0% ±

Excel 2003
На листах с именем номера вагона шапка B14:N14 должна быть всегда,
макрос ориентируется на эту строку
Для вашего последнего примера

[vba]
Код
Sub iNomer()
Dim iNumber As String
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 15
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
For i = 15 To iLastRow 'выделяем из столбца C уникальные номера
If Cells(i, "C") <> "" Then
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
iNumber = .Execute(Cells(i, "C"))(0)
End With
'If Not .exists(Left(Cells(i, "C").Value, 3)) Then
If Not .exists(iNumber) Then
'если нет слова, то добавляем его в словарь и в столбец S
.Add iNumber, 1
Cells(n, "S").NumberFormat = "@" 'текстовый формат ячейки
Cells(n, "S") = iNumber
n = n + 1
End If
End If
Next
End With
iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
For i = 15 To iLastRow 'цикл по уникальным номерам в S
Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
FAdr_Row = FoundCell.Row 'первая строка с уникальным номером
Do
EAdr_Row = FoundCell.Row 'последняя строка с уникальным номером
Set FoundCell = Columns(3).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
With Worksheets(CStr(Cells(i, "S")))
'очищаем диапазон на соответствующем листе
.Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
'копируем диапазон от первой до последней строки + 1 уникального номера
'чтобы захватить строку с ИТОГО по ко-ву
Range("B" & FAdr_Row & ":N" & EAdr_Row + 1).Copy .Range("B15")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B" & iLR + 2) = "Всего"
.Range("D" & iLR + 2) = Application.Sum(.Range("D15:D" & iLR))
.Range("E" & iLR + 2) = Application.Sum(.Range("E15:E" & iLR))
.Range("F" & iLR + 2) = Application.Sum(.Range("F15:F" & iLR))
.Range("N" & iLR + 2) = Application.Sum(.Range("N15:N" & iLR))

.Range("B" & iLR + 4) = "Период формирования акта от: " & Cells(FAdr_Row, "G") & _
" до " & Cells(EAdr_Row, "G")
For n = iLR To 15 Step -1 'удаляем строки на соответствующем листе с ИТОГО
If .Cells(n, "B") Like "ИТОГО*" Then
.Rows(n).Delete
End If
Next
End With
Next
End Sub
[/vba]

Привел пример формирования строки под таблицей "Период формирования акта от: "
Используйте этот принцип для своей шапки под таблицей


Сообщение отредактировал Kuzmich - Вторник, 19.06.2018, 16:25
 
Ответить
СообщениеНа листах с именем номера вагона шапка B14:N14 должна быть всегда,
макрос ориентируется на эту строку
Для вашего последнего примера

[vba]
Код
Sub iNomer()
Dim iNumber As String
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
n = 15
iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
For i = 15 To iLastRow 'выделяем из столбца C уникальные номера
If Cells(i, "C") <> "" Then
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
iNumber = .Execute(Cells(i, "C"))(0)
End With
'If Not .exists(Left(Cells(i, "C").Value, 3)) Then
If Not .exists(iNumber) Then
'если нет слова, то добавляем его в словарь и в столбец S
.Add iNumber, 1
Cells(n, "S").NumberFormat = "@" 'текстовый формат ячейки
Cells(n, "S") = iNumber
n = n + 1
End If
End If
Next
End With
iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
For i = 15 To iLastRow 'цикл по уникальным номерам в S
Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
If Not FoundCell Is Nothing Then
FAdr = FoundCell.Address
FAdr_Row = FoundCell.Row 'первая строка с уникальным номером
Do
EAdr_Row = FoundCell.Row 'последняя строка с уникальным номером
Set FoundCell = Columns(3).FindNext(FoundCell)
Loop While FoundCell.Address <> FAdr
End If
With Worksheets(CStr(Cells(i, "S")))
'очищаем диапазон на соответствующем листе
.Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
'копируем диапазон от первой до последней строки + 1 уникального номера
'чтобы захватить строку с ИТОГО по ко-ву
Range("B" & FAdr_Row & ":N" & EAdr_Row + 1).Copy .Range("B15")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("B" & iLR + 2) = "Всего"
.Range("D" & iLR + 2) = Application.Sum(.Range("D15:D" & iLR))
.Range("E" & iLR + 2) = Application.Sum(.Range("E15:E" & iLR))
.Range("F" & iLR + 2) = Application.Sum(.Range("F15:F" & iLR))
.Range("N" & iLR + 2) = Application.Sum(.Range("N15:N" & iLR))

.Range("B" & iLR + 4) = "Период формирования акта от: " & Cells(FAdr_Row, "G") & _
" до " & Cells(EAdr_Row, "G")
For n = iLR To 15 Step -1 'удаляем строки на соответствующем листе с ИТОГО
If .Cells(n, "B") Like "ИТОГО*" Then
.Rows(n).Delete
End If
Next
End With
Next
End Sub
[/vba]

Привел пример формирования строки под таблицей "Период формирования акта от: "
Используйте этот принцип для своей шапки под таблицей

Автор - Kuzmich
Дата добавления - 19.06.2018 в 16:23
Vselennaya Дата: Среда, 20.06.2018, 08:20 | Сообщение № 24
Группа: Пользователи
Ранг: Новичок
Сообщений: 18
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Kuzmich, СПАСИБО огромное. Последние я надеюсь вопросы. А как сделать заливку строки ВСЕГО на каждом листе и продлить таблицу до этой строки?!
И как заполнить нижнюю шапку именно текст я поняла. А можно просто чтоб в каждом листе она была вставлена так же как верхняя шапка таблицы и просто смещалась соответственно формированию таблицы вниз? В примере цветными вкладками выделила как должно быть и откуда данные берутся. Вот данные я буду сама вставлять и они будут в шапочку верхнюю и нижнюю переноситься. И просто надо чтою смещалась вниз шапка нижняя. Единственное одна цифра будет в саму таблицу проставляться из данных для шапки . Как сделать так, чтобы они проставлялись в таблицу макросом сформированную? %)
К сообщению приложен файл: 6987284.xlsm (89.0 Kb)
 
Ответить
СообщениеKuzmich, СПАСИБО огромное. Последние я надеюсь вопросы. А как сделать заливку строки ВСЕГО на каждом листе и продлить таблицу до этой строки?!
И как заполнить нижнюю шапку именно текст я поняла. А можно просто чтоб в каждом листе она была вставлена так же как верхняя шапка таблицы и просто смещалась соответственно формированию таблицы вниз? В примере цветными вкладками выделила как должно быть и откуда данные берутся. Вот данные я буду сама вставлять и они будут в шапочку верхнюю и нижнюю переноситься. И просто надо чтою смещалась вниз шапка нижняя. Единственное одна цифра будет в саму таблицу проставляться из данных для шапки . Как сделать так, чтобы они проставлялись в таблицу макросом сформированную? %)

Автор - Vselennaya
Дата добавления - 20.06.2018 в 08:20
Kuzmich Дата: Среда, 20.06.2018, 10:21 | Сообщение № 25
Группа: Проверенные
Ранг: Ветеран
Сообщений: 711
Репутация: 156 ±
Замечаний: 0% ±

Excel 2003
Цитата
как сделать заливку строки ВСЕГО на каждом листе и продлить таблицу до этой строки?!

После подсчета сумм добавьте в код строки
[vba]
Код
       iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
       .Range("B" & iLR + 2) = "Всего"
       .Range("D" & iLR + 2) = Application.Sum(.Range("D15:D" & iLR))
       .Range("E" & iLR + 2) = Application.Sum(.Range("E15:E" & iLR))
       .Range("F" & iLR + 2) = Application.Sum(.Range("F15:F" & iLR))
       .Range("N" & iLR + 2) = Application.Sum(.Range("N15:N" & iLR))
       
           'границы таблицы от 15 строки до iLR +2
       .Range("B15:N" & iLR + 2).Borders.Weight = xlThin
           'цвет строки ИТОГО голубой, шрифт полужирный
       .Range("B" & iLR + 2 & ":N" & iLR + 2).Interior.ColorIndex = 8
       .Range("B" & iLR + 2 & ":N" & iLR + 2).Font.Bold = True
[/vba]
По вопросу формирования нижней шапки надо еще подумать, но может ее поместить
на лист 'данные для шапки' и потом копировать на соответствующий лист после таблицы.
Пришлите свой адрес электронной почты, а то у меня размер файла уже превышает 500 Кб
 
Ответить
Сообщение
Цитата
как сделать заливку строки ВСЕГО на каждом листе и продлить таблицу до этой строки?!

После подсчета сумм добавьте в код строки
[vba]
Код
       iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
       .Range("B" & iLR + 2) = "Всего"
       .Range("D" & iLR + 2) = Application.Sum(.Range("D15:D" & iLR))
       .Range("E" & iLR + 2) = Application.Sum(.Range("E15:E" & iLR))
       .Range("F" & iLR + 2) = Application.Sum(.Range("F15:F" & iLR))
       .Range("N" & iLR + 2) = Application.Sum(.Range("N15:N" & iLR))
       
           'границы таблицы от 15 строки до iLR +2
       .Range("B15:N" & iLR + 2).Borders.Weight = xlThin
           'цвет строки ИТОГО голубой, шрифт полужирный
       .Range("B" & iLR + 2 & ":N" & iLR + 2).Interior.ColorIndex = 8
       .Range("B" & iLR + 2 & ":N" & iLR + 2).Font.Bold = True
[/vba]
По вопросу формирования нижней шапки надо еще подумать, но может ее поместить
на лист 'данные для шапки' и потом копировать на соответствующий лист после таблицы.
Пришлите свой адрес электронной почты, а то у меня размер файла уже превышает 500 Кб

Автор - Kuzmich
Дата добавления - 20.06.2018 в 10:21
Vselennaya Дата: Среда, 20.06.2018, 10:32 | Сообщение № 26
Группа: Пользователи
Ранг: Новичок
Сообщений: 18
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Удалено администрацией - нерушение Правил форума
 
Ответить
СообщениеУдалено администрацией - нерушение Правил форума

Автор - Vselennaya
Дата добавления - 20.06.2018 в 10:32
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Распределение данных по листам книги с помощью макроса (Формулы/Formulas, Макросы/Macros)
  • Страница 2 из 2
  • «
  • 1
  • 2
Поиск:

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