Форумы HiProg.com - MS ACCESS, VBA, VB

ник: АлаяЗаря

Sub macro1() f = 2 ' объявляем начальные значение переменной s = 1 ' объявляем начальные значение переменной For a = 2 To 60000 'начало цикла по первому столбцу     If Cells(a, s) = Cells(a + 1, s) Then 'проверка равенства текущей ячейки с следующей     Else '     Range(Cells(f, s), Cells(a, s)).Select 'объединение выявленого диапазона ячеек     Application.DisplayAlerts = False     Selection.Merge         h = f '         For d = f To 60000 '         g = s + 1 '             If Cells(d, g) = Cells(d + 1, g) Then '                 If d = a Then '                 Range(Cells(h, g), Cells(d, g)).Select '                 Application.DisplayAlerts = False                 Selection.Merge                 Exit For '                 Else: End If '             Else '             Range(Cells(h, g), Cells(d, g)).Select '             Application.DisplayAlerts = False             Selection.Merge                 k = h '                 For l = h To 60000 '                 n = g + 1 '                     If Cells(l, n) = Cells(l + 1, n) Then '                         If l = d Then '                         Range(Cells(k, n), Cells(l, n)).Select '                         Application.DisplayAlerts = False                         Selection.Merge                         Exit For '                         Else: End If '                     Else '                     Range(Cells(k, n), Cells(l, n)).Select '                     Application.DisplayAlerts = False                     Selection.Merge                         c = k '                         For v = k To 60000 '                         b = n + 1 '                             If Cells(v, b) = Cells(v + 1, b) Then '                                 If v = l Then '                                 Range(Cells(c, b), Cells(v, b)).Select '                                 Application.DisplayAlerts = False                                 Selection.Merge                                 Exit For '                                 Else: End If '                             Else '                             Range(Cells(c, b), Cells(v, b)).Select '                             Application.DisplayAlerts = False                             Selection.Merge                                 j = c '                                 For q = c To 60000 '                                 w = b + 1 '                                 If Cells(q, w) = Cells(q + 1, w) Then '                                 If q = v Then '                                 Range(Cells(j, w), Cells(q, w)).Select '                                 Application.DisplayAlerts = False                                 Selection.Merge                                 Exit For '                                 Else: End If '                                 Else '                                 Range(Cells(j, w), Cells(q, w)).Select '                                 Application.DisplayAlerts = False                                 Selection.Merge                                 j = q + 1 '                                 If v + 1 = j Then Exit For '                                 End If '                                 Next q '                             c = v + 1 '                             If l + 1 = c Then Exit For '                             End If '                         Next v '                     k = l + 1 '                     If d + 1 = k Then Exit For '                     End If '                 Next l '             h = d + 1 '             If a + 1 = h Then Exit For '             End If '         Next d '     f = a + 1 '     If Cells(f, s) = 0 Then Exit For '     End If ' Next a ' End Sub '

но на 7 тысяч записей выполняется около двух - трех минут на буке, на ПК (а они не ахти) еще дольше...