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

Вход

Регистрация

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

 

= Мир MS Excel/Копирование данных по листам на основании значения - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование данных по листам на основании значения (Макросы/Sub)
Копирование данных по листам на основании значения
bosika Дата: Суббота, 26.11.2016, 16:35 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 105
Репутация: 0 ±
Замечаний: 40% ±

Excel 2010, 2013, 2016
Доброе время суток ГУРУ.
Как говориться, без ВАС никуда.
Появилась задачка разнести данные с одного листа "Цеха" по листам по проставленному значению в колонке Н.
Сделал запись макрорекордером, но увы, дальше дело не идет.
В файле на вкладке Цеха описано желаемое. Если можно, то макросом без кнопки, при загрузке файла.
Заранее благодарен за помощь.
К сообщению приложен файл: 6840626.xlsm (22.3 Kb)

Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
СообщениеДоброе время суток ГУРУ.
Как говориться, без ВАС никуда.
Появилась задачка разнести данные с одного листа "Цеха" по листам по проставленному значению в колонке Н.
Сделал запись макрорекордером, но увы, дальше дело не идет.
В файле на вкладке Цеха описано желаемое. Если можно, то макросом без кнопки, при загрузке файла.
Заранее благодарен за помощь.
Автор - bosika
Дата добавления - 26.11.2016 в 16:35
gling Дата: Суббота, 26.11.2016, 17:22 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2525
Репутация: 678 ±
Замечаний: 0% ±

2010
Здравствуйте. Нарисовал страшную формулу, для всех листов с номером цеха. Думаю разберетесь.
Код
=ЕСЛИОШИБКА(ИНДЕКС(Цеха!$B$1:$H$22;СУММПРОИЗВ(НАИБОЛЬШИЙ((Цеха!$H$4:$H$22=--ПРАВСИМВ(ПСТР(ЯЧЕЙКА("имяфайла";A1);ПОИСК("]";ЯЧЕЙКА("имяфайла";A1))+1;5)))*СТРОКА(Цеха!$H$4:$H$22);СЧЁТЕСЛИ(Цеха!$H$4:$H$22;--ПРАВСИМВ(ПСТР(ЯЧЕЙКА("имяфайла";A1);ПОИСК("]";ЯЧЕЙКА("имяфайла";A1))+1;5)))-(СТРОКА(F1)-1)));СТОЛБЕЦ(A3));"")
К сообщению приложен файл: 3232465.xlsm (52.5 Kb)

ЯД-41001506838083
 
Ответить
СообщениеЗдравствуйте. Нарисовал страшную формулу, для всех листов с номером цеха. Думаю разберетесь.
Код
=ЕСЛИОШИБКА(ИНДЕКС(Цеха!$B$1:$H$22;СУММПРОИЗВ(НАИБОЛЬШИЙ((Цеха!$H$4:$H$22=--ПРАВСИМВ(ПСТР(ЯЧЕЙКА("имяфайла";A1);ПОИСК("]";ЯЧЕЙКА("имяфайла";A1))+1;5)))*СТРОКА(Цеха!$H$4:$H$22);СЧЁТЕСЛИ(Цеха!$H$4:$H$22;--ПРАВСИМВ(ПСТР(ЯЧЕЙКА("имяфайла";A1);ПОИСК("]";ЯЧЕЙКА("имяфайла";A1))+1;5)))-(СТРОКА(F1)-1)));СТОЛБЕЦ(A3));"")
Автор - gling
Дата добавления - 26.11.2016 в 17:22
Manyasha Дата: Суббота, 26.11.2016, 17:37 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
bosika, здравствуйте. Вариант макроса:
[vba]
Код
Private Sub Workbook_Open()
    Dim lr1&, lr2&, lc&, i&, sh As Worksheet
    With ThisWorkbook.Sheets("Цеха")
        lr1 = .Cells(Rows.Count, 2).End(xlUp).Row
        lc = .Cells(3, Columns.Count).End(xlToLeft).Column
        On Error Resume Next
        For i = 4 To lr1
            If .Cells(i, "h") <> "" Then
                Set sh = ThisWorkbook.Sheets("Цех" & .Cells(i, "h"))
                lr2 = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1
                If Err.Number Then
                    Set sh = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    sh.Name = "Цех" & .Cells(i, "h")
                    lr2 = 3
                    Err.Clear
                End If
                sh.Cells(lr2, 2).Resize(, lc).Value = .Cells(i, 2).Resize(, lc).Value
                'Стереть строчку с листа Цеха
'                .Cells(i, 2).Resize(, 7).ClearContents
            End If
        Next i
    End With
End Sub
[/vba]
К сообщению приложен файл: 6840626-1.xlsm (16.9 Kb)

ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеbosika, здравствуйте. Вариант макроса:
[vba]
Код
Private Sub Workbook_Open()
    Dim lr1&, lr2&, lc&, i&, sh As Worksheet
    With ThisWorkbook.Sheets("Цеха")
        lr1 = .Cells(Rows.Count, 2).End(xlUp).Row
        lc = .Cells(3, Columns.Count).End(xlToLeft).Column
        On Error Resume Next
        For i = 4 To lr1
            If .Cells(i, "h") <> "" Then
                Set sh = ThisWorkbook.Sheets("Цех" & .Cells(i, "h"))
                lr2 = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1
                If Err.Number Then
                    Set sh = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    sh.Name = "Цех" & .Cells(i, "h")
                    lr2 = 3
                    Err.Clear
                End If
                sh.Cells(lr2, 2).Resize(, lc).Value = .Cells(i, 2).Resize(, lc).Value
                'Стереть строчку с листа Цеха
'                .Cells(i, 2).Resize(, 7).ClearContents
            End If
        Next i
    End With
End Sub
[/vba]
Автор - Manyasha
Дата добавления - 26.11.2016 в 17:37
bosika Дата: Суббота, 26.11.2016, 17:47 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 105
Репутация: 0 ±
Замечаний: 40% ±

Excel 2010, 2013, 2016
Manyasha, Огромное спасибо, все работает прекрасно. Нельзя ли сделать так, что бы только фамилии переносились.

Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
СообщениеManyasha, Огромное спасибо, все работает прекрасно. Нельзя ли сделать так, что бы только фамилии переносились.
Автор - bosika
Дата добавления - 26.11.2016 в 17:47
bosika Дата: Суббота, 26.11.2016, 17:49 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 105
Репутация: 0 ±
Замечаний: 40% ±

Excel 2010, 2013, 2016
gling, Большое спасибо. Данных обрабатывать приходиться много, так что разберусь где можно облегчить работу при помощи формулы.

Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
Сообщениеgling, Большое спасибо. Данных обрабатывать приходиться много, так что разберусь где можно облегчить работу при помощи формулы.
Автор - bosika
Дата добавления - 26.11.2016 в 17:49
bosika Дата: Суббота, 26.11.2016, 17:57 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 105
Репутация: 0 ±
Замечаний: 40% ±

Excel 2010, 2013, 2016
Manyasha, И еще один ньюанс. При повторном открытии файла, одни и те же фамилии добавляются, т.е. идет дублирование.

Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
СообщениеManyasha, И еще один ньюанс. При повторном открытии файла, одни и те же фамилии добавляются, т.е. идет дублирование.
Автор - bosika
Дата добавления - 26.11.2016 в 17:57
Manyasha Дата: Суббота, 26.11.2016, 18:45 | Сообщение № 7
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
bosika, так надо?
[vba]
Код
Private Sub Workbook_Open()
    Dim lr1&, lr2&, lc&, i&, sh As Worksheet, x As Range
    With ThisWorkbook.Sheets("Цеха")
        lr1 = .Cells(Rows.Count, 2).End(xlUp).Row
        lc = .Cells(3, Columns.Count).End(xlToLeft).Column
        On Error Resume Next
        For i = 4 To lr1
            If .Cells(i, "h") <> "" Then
                Set sh = ThisWorkbook.Sheets("Цех" & .Cells(i, "h"))
                lr2 = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1
                If Err.Number Then
                    Set sh = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    sh.Name = "Цех" & .Cells(i, "h")
                    lr2 = 3
                    Err.Clear
                End If
                Set x = sh.Columns(2).Find(.Cells(i, 2), , , xlWhole)
                If x Is Nothing Then sh.Cells(lr2, 2) = .Cells(i, 2)
            End If
        Next i
    End With
End Sub
[/vba]

ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеbosika, так надо?
[vba]
Код
Private Sub Workbook_Open()
    Dim lr1&, lr2&, lc&, i&, sh As Worksheet, x As Range
    With ThisWorkbook.Sheets("Цеха")
        lr1 = .Cells(Rows.Count, 2).End(xlUp).Row
        lc = .Cells(3, Columns.Count).End(xlToLeft).Column
        On Error Resume Next
        For i = 4 To lr1
            If .Cells(i, "h") <> "" Then
                Set sh = ThisWorkbook.Sheets("Цех" & .Cells(i, "h"))
                lr2 = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1
                If Err.Number Then
                    Set sh = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    sh.Name = "Цех" & .Cells(i, "h")
                    lr2 = 3
                    Err.Clear
                End If
                Set x = sh.Columns(2).Find(.Cells(i, 2), , , xlWhole)
                If x Is Nothing Then sh.Cells(lr2, 2) = .Cells(i, 2)
            End If
        Next i
    End With
End Sub
[/vba]
Автор - Manyasha
Дата добавления - 26.11.2016 в 18:45
bosika Дата: Суббота, 26.11.2016, 19:07 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 105
Репутация: 0 ±
Замечаний: 40% ±

Excel 2010, 2013, 2016
Manyasha, Сейчас погоняю на файле.

Начинающий. Много и долго не пинать. Больно однако.

Сообщение отредактировал bosika - Суббота, 26.11.2016, 19:14
 
Ответить
СообщениеManyasha, Сейчас погоняю на файле.
Автор - bosika
Дата добавления - 26.11.2016 в 19:07
bosika Дата: Суббота, 26.11.2016, 19:11 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 105
Репутация: 0 ±
Замечаний: 40% ±

Excel 2010, 2013, 2016
Manyasha, Извините, не посмотрел что русский текст не прописался в коде. Работает на УРА. Огромное Вам спасибо. Еще раз извините за мою невнимательность. +

Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
СообщениеManyasha, Извините, не посмотрел что русский текст не прописался в коде. Работает на УРА. Огромное Вам спасибо. Еще раз извините за мою невнимательность. +
Автор - bosika
Дата добавления - 26.11.2016 в 19:11
bosika Дата: Суббота, 26.11.2016, 19:13 | Сообщение № 10
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 105
Репутация: 0 ±
Замечаний: 40% ±

Excel 2010, 2013, 2016
Спасибо Вам большое за помощь. Тему можно закрывать.

Начинающий. Много и долго не пинать. Больно однако.
 
Ответить
СообщениеСпасибо Вам большое за помощь. Тему можно закрывать.
Автор - bosika
Дата добавления - 26.11.2016 в 19:13
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование данных по листам на основании значения (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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