Добрый вечер! Есть база данных ,которая постоянно пополняется, на данный момент количество строк в ней 90000. В базе есть несколько столбиков, столбик В содержит в себе перечень номеров,столбики D,F,H,J,L,N содержат номера которые надо удалять из столбика А. В столбиках ,C,E,G,I,J,M содерждиться формула =ВПР. Удаление данных из А ,происходит вручную по результатам C,E,G,I,J,M. Так же есть столбик D из которого надо исключить данные находящиеся в столбике L. Появилась проблема того,что из за большого количества номеров ,почти каждое действие обрабатывается по несколько минут,а иногда и комп просто зависает. Идея в том, что б как то оптимизировать и облегчить базу,в идеале,что б удаление происходило автоматически или путём выполнения какого то скрипта. Помогите пожалуйста )
Добрый вечер! Есть база данных ,которая постоянно пополняется, на данный момент количество строк в ней 90000. В базе есть несколько столбиков, столбик В содержит в себе перечень номеров,столбики D,F,H,J,L,N содержат номера которые надо удалять из столбика А. В столбиках ,C,E,G,I,J,M содерждиться формула =ВПР. Удаление данных из А ,происходит вручную по результатам C,E,G,I,J,M. Так же есть столбик D из которого надо исключить данные находящиеся в столбике L. Появилась проблема того,что из за большого количества номеров ,почти каждое действие обрабатывается по несколько минут,а иногда и комп просто зависает. Идея в том, что б как то оптимизировать и облегчить базу,в идеале,что б удаление происходило автоматически или путём выполнения какого то скрипта. Помогите пожалуйста )alex_fly
Sub jjj() ' обработка телефонов в столбце B НАЧАТА Set datas = [b2] Set rtemp = datas: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set teltocheck = rtemp
Set rtemp = [d2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngd = rtemp Set rtemp = [f2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngf = rtemp Set rtemp = [h2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngh = rtemp Set rtemp = [j2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngj = rtemp Set rtemp = [l2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngl = rtemp Set rtemp = [n2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngn = rtemp Set rtemp = Nothing Set teltodel = Application.Union(rngd, rngf, rngh, rngj, rngl, rngn) Set rngf = Nothing: Set rngh = Nothing: Set rngj = Nothing: Set rngn = Nothing
Set dicteltocheck = CreateObject("Scripting.Dictionary") Set dicteltodel = CreateObject("Scripting.Dictionary")
For Each cl In teltocheck If Len(cl.Value) Then dicteltocheck(cl.Value) = cl.Value Next cl For Each cl In teltodel If Len(cl.Value) Then dicteltodel(cl.Value) = cl.Value Next cl Set teltodel = Nothing
For Each dd In dicteltodel If dicteltocheck.Exists(dd) Then dicteltocheck.Remove dd: Debug.Print dd Next dd
teltocheck.ClearContents Set teltocheck = Nothing i = 0 For Each dc In dicteltocheck datas.Offset(i).Value = dc i = i + 1 Next dc dicteltocheck.RemoveAll dicteltodel.RemoveAll ' обработка телефонов в столбце B окончена ' обработка телефонов в столбце D НАЧАТА Set datas = rngd.Resize(1, 1) Set teltocheck = rngd Set teltodel = rngl
For Each cl In teltocheck If Len(cl.Value) Then dicteltocheck(cl.Value) = cl.Value Next cl For Each cl In teltodel If Len(cl.Value) Then dicteltodel(cl.Value) = cl.Value Next cl Set teltodel = Nothing
For Each dd In dicteltodel If dicteltocheck.Exists(dd) Then dicteltocheck.Remove dd Next dd Debug.Print
teltocheck.ClearContents Set teltocheck = Nothing i = 0 For Each dc In dicteltocheck datas.Offset(i).Value = dc i = i + 1 Next dc dicteltocheck.RemoveAll dicteltodel.RemoveAll ' обработка телефонов в столбце D окончена End Sub
[/vba]
Макрос на кнопке. Тестируйте.
[vba]
Код
Sub jjj() ' обработка телефонов в столбце B НАЧАТА Set datas = [b2] Set rtemp = datas: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set teltocheck = rtemp
Set rtemp = [d2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngd = rtemp Set rtemp = [f2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngf = rtemp Set rtemp = [h2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngh = rtemp Set rtemp = [j2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngj = rtemp Set rtemp = [l2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngl = rtemp Set rtemp = [n2]: With rtemp: Set lcl = .Offset(Rows.Count - .Row).End(xlUp): Set rtemp = Range(.Address, IIf(lcl.Row > .Row, lcl, .Address)): End With: Set rngn = rtemp Set rtemp = Nothing Set teltodel = Application.Union(rngd, rngf, rngh, rngj, rngl, rngn) Set rngf = Nothing: Set rngh = Nothing: Set rngj = Nothing: Set rngn = Nothing
Set dicteltocheck = CreateObject("Scripting.Dictionary") Set dicteltodel = CreateObject("Scripting.Dictionary")
For Each cl In teltocheck If Len(cl.Value) Then dicteltocheck(cl.Value) = cl.Value Next cl For Each cl In teltodel If Len(cl.Value) Then dicteltodel(cl.Value) = cl.Value Next cl Set teltodel = Nothing
For Each dd In dicteltodel If dicteltocheck.Exists(dd) Then dicteltocheck.Remove dd: Debug.Print dd Next dd
teltocheck.ClearContents Set teltocheck = Nothing i = 0 For Each dc In dicteltocheck datas.Offset(i).Value = dc i = i + 1 Next dc dicteltocheck.RemoveAll dicteltodel.RemoveAll ' обработка телефонов в столбце B окончена ' обработка телефонов в столбце D НАЧАТА Set datas = rngd.Resize(1, 1) Set teltocheck = rngd Set teltodel = rngl
For Each cl In teltocheck If Len(cl.Value) Then dicteltocheck(cl.Value) = cl.Value Next cl For Each cl In teltodel If Len(cl.Value) Then dicteltodel(cl.Value) = cl.Value Next cl Set teltodel = Nothing
For Each dd In dicteltodel If dicteltocheck.Exists(dd) Then dicteltocheck.Remove dd Next dd Debug.Print
teltocheck.ClearContents Set teltocheck = Nothing i = 0 For Each dc In dicteltocheck datas.Offset(i).Value = dc i = i + 1 Next dc dicteltocheck.RemoveAll dicteltodel.RemoveAll ' обработка телефонов в столбце D окончена End Sub