Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме 85 тыс рублей в месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 13.08.2013, 22:41   #1
filton
Пользователь
 
Регистрация: 13.08.2013
Сообщений: 10
По умолчанию Кнопка для внесения значений на несколько листов сразу

Здравствуйте!

На втором листе размещены данные, которые нужно сопоставлять с первым листом и, при совпадении id, выделять цветом и добавлять "дату открепления".

Знаний у меня в VBA не очень много, поэтому прошу помощи в доработке кнопки. Недостаток в том, что кнопка работает только на 2 листа. В основном проекте листов будет больше, данные с листа2 из примера будут, скажем, на листе7 и нужно, чтобы данные с листа7 сверялись со всеми остальными листами в книге и при совпадении id (на всех листах будет 1й столбец с id, но остальных столбцов может быть разное количество) закрашивалась строка и добавлялась дата, как в прикреплении. Данные на лист7 будут постоянно добавляться/удаляться вручную.

Ну и мне показался мой код громоздким из-за двух for each, можно ли его как-то оптимизировать, слив их в одно?

Заранее большое спасибо.
Вложения
Тип файла: rar Лист Microsoft Excel.rar (18.6 Кб, 18 просмотров)
filton вне форума Ответить с цитированием
Старый 14.08.2013, 00:28   #2
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,163
По умолчанию

Так будет побыстрее, и цикл по листам несложно прикрутить:
Код:
Private Sub CommandButton1_Click()
    Dim a(), i&
    a = Worksheets("лист2").[A1].CurrentRegion.Value
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a): .Item(a(i, 1)) = a(i, 2): Next
        a = Worksheets("лист1").[A1].CurrentRegion.Value
        ReDim b(1 To UBound(a), 1 To 1)
        For i = 2 To UBound(a)
            If .exists(a(i, 1)) Then
                b(i, 1) = .Item(a(i, 1))
                Worksheets("лист1").Range("A" & i).Resize(, 4).Interior.ColorIndex = 6
            End If
        Next
    End With
    Worksheets("лист1").Cells(1, UBound(a, 2) + 1).Resize(UBound(b), 1) = b
    MsgBox "Готово!"
End Sub
Если отказаться от покраски - будет вообще мнгновенно
webmoney: E265281470651 Z422237915069 R418926282008

Последний раз редактировалось Hugo121; 14.08.2013 в 00:46.
Hugo121 вне форума Ответить с цитированием
Старый 14.08.2013, 01:09   #3
filton
Пользователь
 
Регистрация: 13.08.2013
Сообщений: 10
По умолчанию

Круто, гораздо быстрее моего варианта) А по какому принципу добавляется дата в лист1? Вот тут сложность в том, что в лист2 будут добавляться новые id и даты вместо старых, а в лист1 эти даты добавляются следующим столбцом, а должны в тот же падать, вместе со старыми. Проще говоря именно в конец строки, а не в 4й столбец.
А можно вместо лист2 воткнуть activeworksheet? Будут приходить новые документы с датами откреплений, из них пользователь будет копипастить данные на лист с кнопкой и тыкать ее.
А If .exists(a(i, 1)) Then означает, что пустые строки не будут участвовать при сканировании лист1 , верно? Они вообще помешают? Просто могут оказаться на любом листе.

Доработал свою кнопку, добавив ws и указав все листы в целевой ренж. Это почти то, что нужно, но слишком медленно, объем данных очень большой в итоговом проекте. Плюс дату нужно именно в конец строки.
Код:
Private Sub CommandButton1_Click()
 Dim RangeIn As Variant, Lists As Variant, x As Variant, y As Variant
    For Each ws In Worksheets
    Set RangeIn = Worksheets("лист2").Range("A2:A172")
    Set Lists = Worksheets(ws.Name).Range("A2:A172")
    For Each x In Lists
        For Each y In RangeIn
            If x = y And Len(x) <> 0 Then x.Resize(x.Rows.Count, _
   x.Columns.Count + 4).Interior.ColorIndex = 6
    Next y
    Next x
        For Each x In Lists
        For Each y In RangeIn
            If x = y And Len(x) <> 0 Then x.Offset(0, 4) = y.Offset(0, 1)
    Next y
    Next x
Next ws
    MsgBox "Готово!"
End Sub

Последний раз редактировалось filton; 14.08.2013 в 01:26.
filton вне форума Ответить с цитированием
Старый 14.08.2013, 22:05   #4
filton
Пользователь
 
Регистрация: 13.08.2013
Сообщений: 10
По умолчанию

Код:
Private Sub CommandButton1_Click()
 Dim RangeIn As Variant, Lists As Variant, x As Variant, y As Variant
    For Each ws In Worksheets
    Set RangeIn = Worksheets("лист2").Range("A2:A172")
    Set Lists = Worksheets(ws.Name).Range("A2:A172")
    For Each x In Lists
        For Each y In RangeIn
            If x = y And Len(x) <> 0 Then x.Resize(x.Rows.Count, x.Columns.Count + 4).Interior.ColorIndex = 6
    Next y
    Next x
    For Each x In Lists
       For Each y In RangeIn
          If x = y And Len(x) <> 0 Then x.Offset(0, 4) = y.Offset(0, 1)
Next y
Next x
Next ws
    MsgBox "Готово!"
End Sub
Как можно оптимизировать и сделать чтобы запись добавлялась не x.Offset(0, 4), а в конец строки?
filton вне форума Ответить с цитированием
Старый 14.08.2013, 22:08   #5
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,163
По умолчанию

Даже не знаю на что отвечать...
Лучше помолчу.
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 14.08.2013, 23:02   #6
filton
Пользователь
 
Регистрация: 13.08.2013
Сообщений: 10
По умолчанию

на последнее, если не трудно
filton вне форума Ответить с цитированием
Старый 14.08.2013, 23:18   #7
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,163
По умолчанию

А конец строки - это где?
В общем мой код и пишет всегда в конец строки
Но Вы его забраковали...
webmoney: E265281470651 Z422237915069 R418926282008

Последний раз редактировалось Hugo121; 14.08.2013 в 23:26.
Hugo121 вне форума Ответить с цитированием
Старый 14.08.2013, 23:49   #8
filton
Пользователь
 
Регистрация: 13.08.2013
Сообщений: 10
По умолчанию

Цитата:
Сообщение от Hugo121 Посмотреть сообщение
А конец строки - это где?
Первая пустая ячейка в ряду.
Ваш код добавляет все в первый свободный столбец. Данные на лист2 будут удаляться и вставляться из других документов, след-но каждое такое изменение будет на первом листе новым столбцом , а нужно чтобы эти даты были в одном и том же столбце(чтобы новые даты добавлялись в столбец к старым, которые были уже добавлены кодом ранее). В идеале, чтобы добавлялось именно в, пустую ячейку ряда.
К тому же при наличии пустых рядов на листе1, код перестает выполняться.
Надеюсь, в этот раз более понятно получилось)

Последний раз редактировалось filton; 14.08.2013 в 23:53.
filton вне форума Ответить с цитированием
Старый 15.08.2013, 21:45   #9
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,163
По умолчанию

Ну я конечно такое и предполагал, не совсем дурак...
Но бывают разные задачи - для другой задачи мой код вполне подходил. Например под Ваш пример
А так всё поправимо - и строки пустые можно игнорировать, и дополнять.
А с "Первая пустая ячейка в ряду" думаю Вы не подумав написали.
Ведь может быть таких два ряда:
www www www
www www
Так куда нужно писать эти вытянутые данные?

Ладно занудствовать
Вот с минимальными переделками под переделанную задачу:

Код:
Private Sub CommandButton1_Click()
    Dim a(), b(), i&
    a = Worksheets("лист2").[A1].CurrentRegion.Value
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a): .Item(a(i, 1)) = a(i, 2): Next
        
        With Worksheets("лист1")
        a = .Range(.[A1], Range("D" & .Rows.Count).End(xlUp)).Value
        b = .Range(.Cells(1, "E"), .Cells(UBound(a), "E")).Value
        End With

        For i = 2 To UBound(a)
            If .exists(a(i, 1)) Then
                b(i, 1) = .Item(a(i, 1))
                Worksheets("лист1").Range("A" & i).Resize(, 4).Interior.ColorIndex = 6
            End If
        Next
    End With
    Worksheets("лист1").Cells(1, UBound(a, 2) + 1).Resize(UBound(b), 1) = b
    MsgBox "Готово!"
End Sub
webmoney: E265281470651 Z422237915069 R418926282008

Последний раз редактировалось Hugo121; 15.08.2013 в 22:17.
Hugo121 вне форума Ответить с цитированием
Старый 27.08.2013, 00:43   #10
filton
Пользователь
 
Регистрация: 13.08.2013
Сообщений: 10
По умолчанию

Был в отпуске. Большое спасибо за помощь.
Ваш код выше выдает ошибку 1004 application-defined or object-defined error
a = .Range(.[A1], Range("D" & .Rows.Count).End(xlUp)).Value

Попытаюсь еще раз объяснить задачу. На лист2 будут периодически вручную вноситься новые данные, а старые удаляться. Т.е. лист2 как бы существует только ради одного нажатия кнопки, ради сравнения данных с него с остальными листами во всей книге. Данные на лист2 могут быть вразнобой, т.е. не в том порядке, в каком они на остальных листах. При совпадении значения с листа2 и значения на любом другом листе происходит следующее: закрашиваются совпавшая ячейка и 3(например) справа от нее(столбцы B,C,D), а также добавляется значение из столбца "B" с листа2 в столбец E справа от совпавшей ячейки.

Вот моя кнопка, которая работает медленно, данные в итоге будут под 30000 строк. Может быть, этот код внесет ясность.
Код:
Private Sub CommandButton1_Click()
 Dim RangeIn As Variant, Lists As Variant, x As Variant, y As Variant
    For Each ws In Worksheets
    Set RangeIn = ActiveSheet.Range("a1:a300")
    Set Lists = Worksheets(ws.Name).Range("a1:a300")
    For Each x In Lists
        For Each y In RangeIn
            If x = y And Len(x) <> 0 Then x.Resize(x.Rows.Count, x.Columns.Count + 4).Interior.ColorIndex = 6
    Next y
    Next x
For Each x In Lists
       For Each y In RangeIn
            If x = y And Len(x) <> 0 Then x.Offset(0, 4) = y.Offset(0, 1)
    Next y
    Next x
Next ws
    MsgBox "Готово!"
End Sub
filton вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме 85 тыс рублей в месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
1) как перетащить несколько модулей с одной книги на другую одним скопом? 2)можно ли открыть несколько книг сразу? БАХТИ Microsoft Office Excel 17 26.09.2011 18:11
«Найти и заменить» сразу несколько значений. Smile2007 Microsoft Office Excel 9 09.12.2010 00:36
Как выделить несколько листов сразу? frantic150 Microsoft Office Excel 3 25.06.2009 01:25
Как вставить столбик с формулами сразу на 50 листов? Катик7 Microsoft Office Excel 2 01.05.2009 16:26
Снятие Защиты с листов, сразу со всех valerij Microsoft Office Excel 2 02.11.2007 21:19