Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.60/5: Рейтинг темы: голосов - 5, средняя оценка - 4.60
1011 / 468 / 120
Регистрация: 27.02.2013
Сообщений: 1,348
1

Упростить код для считывания цвета ячеек в выделенном диапазоне

10.02.2016, 14:29. Показов 981. Ответов 14
Метки нет (Все метки)

Уважаемые программисты.
Написал код для считывания цвета ячеек в выделенном диапазоне и составления таблицы для построения графика по этой таблице.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub Макросforeach()
 
Sheets("Лист1").Select
Range("A1000:DP60000").ClearContents
 
 Set aRange = Application.InputBox(prompt:="Выберите диапазон", Type:=8)
  If aRange Is Nothing Then
    MsgBox "Ошибка выбора диапазона"
  Else
  Application.ScreenUpdating = False
  For i = 1 To 56 'индекс цвета
    aRange.Select
 r = 1
 c = 1
For Each c In aRange
 If c.Interior.ColorIndex = i Then
 i = c.Interior.ColorIndex
 MyRow = c.Row
 MyCol = c.Column
 Cells(1000 + r, i * 2 + 1).Value = MyRow
 Cells(1000 + r, i * 2 + 2).Value = MyCol
 r = r + 1
End If
 Next c
  Next i
   End If
End Sub
Все работает,но долго,т.к. цикл For Each выполняется 56 раз для выборки каждого цвета.

Решил упростить код и считывать все данные за один проход
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Макросforeach1()
 
Sheets("Лист1").Select
Range("A1000:DP60000").ClearContents
 
 Set aRange = Application.InputBox(prompt:="Выберите диапазон", Type:=8)
  If aRange Is Nothing Then
    MsgBox "Ошибка выбора диапазона"
  Else
  Application.ScreenUpdating = False
    aRange.Select
 r = 1
 c = 1
For Each c In aRange
 i = c.Interior.ColorIndex
 MyRow = c.Row
 MyCol = c.Column
 Cells(1000 + r, i * 2 + 1).Value = MyRow
 Cells(1000 + r, i * 2 + 2).Value = MyCol
 r = r + 1
 Next c
   End If
End Sub
По столбцам все разносится правильно,а вот по строкам получается со сдвигом и пропусками в столбцах.
Причину понимаю.Не правильно идет изменение r .А вот как исправить ошибку логически знаю(необходимо перед внесением данных определять последнюю строку в нужном столбце),а практически полный ноль.
т.е. переменная r должна быть равна последней заполненной ячейке в конкретном столбце.
С уважением,Olegoff.
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
10.02.2016, 14:29
Ответы с готовыми решениями:

В выделенном диапазоне ячеек поменять цвет заливки всех ячеек с числами
лабараторная 6 Задание 1. Напишите код программы, которая бы закрывала без сохранения изменений...

Подсчет суммы ячеек в выделенном диапазоне
Как сделать чтобы выделенный диапазон суммировался и записывался ячейкой ниже?

Узнать, что в выделенном диапазоне ячеек есть пустые
Знает ли кто, можно как-нибудь узнать что в выделенном диапазоне ячеек есть пустые ячейки, помимо...

Excel - Определить количество ячеек в произвольном выделенном диапазоне
Помогите решить задачу) Определить количество ячеек в произвольном выделенном диапазоне. Буду очень...

__________________
14
3383 / 2080 / 684
Регистрация: 02.11.2012
Сообщений: 5,439
10.02.2016, 16:18 2
зачем вы привязались к номеру цвета? Вообще лучше пример набросайте что есть и что должно получиться.
0
1011 / 468 / 120
Регистрация: 27.02.2013
Сообщений: 1,348
10.02.2016, 16:24  [ТС] 3
Файл прилагаю
0
Вложения
Тип файла: zip Седово.zip (1.76 Мб, 4 просмотров)
3383 / 2080 / 684
Регистрация: 02.11.2012
Сообщений: 5,439
10.02.2016, 17:52 4
опыта очень мало. но может такой подход быстрее будет.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub vvv()
Dim myar()
Set aRange = Application.InputBox(prompt:="Выберите диапазон", Type:=8)
  If aRange Is Nothing Then
    MsgBox "Ошибка выбора диапазона"
  Else
  Application.ScreenUpdating = False
ReDim myar(1 To aRange.Count, 1 To 112)
ReDim n(1 To 56)
For Each c In aRange
i = c.Interior.ColorIndex
n(i) = n(i) + 1
myar(n(i), c.Interior.ColorIndex * 2 - 1) = c.Row
myar(n(i), c.Interior.ColorIndex * 2) = c.Column
Next
End If
Range("A10").Resize(UBound(myar, 1), UBound(myar, 2)) = myar
End Sub
на пустые ячейки будет ругаться нужно обход дописывать.
2
3201 / 952 / 221
Регистрация: 29.05.2010
Сообщений: 2,069
10.02.2016, 18:18 5
Попробуйте цикл заменить таким кодом:
Visual Basic
1
2
3
4
5
6
    For Each c In aRange
        i = c.Interior.ColorIndex
        r = Cells(1000, i * 2 + 1).End(xlDown).Row + 1
        Cells(1000 + r, i * 2 + 1).Value = c.Row
        Cells(1000 + r, i * 2 + 2).Value = c.Column
    Next c
1
15018 / 6346 / 1725
Регистрация: 24.09.2011
Сообщений: 9,976
10.02.2016, 19:07 6
Vlad999, очень хорошо, я бы так же делал. Но зачем в цикле два лишних раза обращаться к c.Interior.ColorIndex?
13-14 строки
Visual Basic
1
2
myar(n(i), i * 2 - 1) = c.Row
myar(n(i), i * 2) = c.Column
Типы переменных еще
Visual Basic
1
Dim myar(), n(1 To 56) As Long, i As Long
1
1011 / 468 / 120
Регистрация: 27.02.2013
Сообщений: 1,348
10.02.2016, 21:51  [ТС] 7
Vlad999,большое спасибо.Ваш код работает как надо.Пустых ячеек буду избегать.Просто их и не должно там быть.
Спасибо и Казанский за поправки и уточнения.
Буду еще изучать как и что работает.У меня с массивами вообще никак пока.
Единственная просьба,если возможно.В некоторых случаях количество точек цвета превышает максимальное количество строк в листе.Возможно-ли вклинить проверку на размер массива и если размер превышает 65536-1000 точек,то запись велась бы в ячейки соответствующего столбца+112.
Т.е.если переполнен столбец 36(37),то дальше запись должна идти в столбец 148(149)

Добавлено через 4 минуты
toiai,спасибо за помощь.
Вставил ваш код,но выдает ошибку в 4 строке,т.к. почему-то не определена величина переменной r в 3 строке,хотя по мысли я все понял вроде правильно.
0
3201 / 952 / 221
Регистрация: 29.05.2010
Сообщений: 2,069
10.02.2016, 22:04 8
Можно писать сразу на другой лист:
Visual Basic
1
2
3
4
5
6
For Each c In aRange
        i = c.Interior.ColorIndex
        r = Sheets("Лист3").Cells(1, i * 2 + 1).End(xlDown).Row + 1
        Sheets("Лист3").Cells(r, i * 2 + 1).Value = c.Row
        Sheets("Лист3").Cells(r, i * 2 + 2).Value = c.Column
    Next c
0
1011 / 468 / 120
Регистрация: 27.02.2013
Сообщений: 1,348
10.02.2016, 23:07  [ТС] 9
toiai,прогнал код в режиме отладки.Переменная i изменяет свои значения в зависимости от индекса цвета,а вот переменная r почему-то всегда равна 3 ???
И вывод данных идет только в третью строку каждого столбца
0
3201 / 952 / 221
Регистрация: 29.05.2010
Сообщений: 2,069
11.02.2016, 18:35 10
Вот посмотрел детальней и исправил:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub ttt()
    Dim myar()
    Set aRange = Application.InputBox(prompt:="Выберите диапазон", Type:=8)
    If aRange Is Nothing Then
        MsgBox "Ошибка выбора диапазона"
    Else
        Application.ScreenUpdating = False
        For Each c In aRange
            i = c.Interior.ColorIndex
            With Sheets("Лист4")
                r = .Cells(.Rows.Count, i * 2 + 1).End(xlUp).Row + 1
                If IsEmpty(.Cells(1, i * 2 + 1)) Then r = 1
                .Cells(r, i * 2 + 1).Value = c.Row
                .Cells(r, i * 2 + 2).Value = c.Column
            End With
        Next c
    End If
    Application.ScreenUpdating = True
End Sub
но вариант с массивами намного быстрее...
1
1011 / 468 / 120
Регистрация: 27.02.2013
Сообщений: 1,348
12.02.2016, 12:33  [ТС] 11
toiai,спасибо все работает.(медленно,но уверенно)
В варианте с массивами всё быстрее,но всплыл один недостаток,число всех точек не должно превышать 65536.
Буду думать как обойти данное ограничение.

Добавлено через 16 часов 14 минут
Vlad999,в вашем коде при количестве точек более 65536 в строке
Цитата Сообщение от Vlad999 Посмотреть сообщение
Range("A10").Resize(UBound(myar, 1), UBound(myar, 2)) = myar
величина UBound(myar, 1) принимает соответственное значение и выдает ошибку.
Пытался методом "научного тыка" разделить вывод данных на два диапазона.(AJ) и (DK:HT),но был приятно удивлен,что все сработало в одном диапазоне.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Sub vvv()
Dim myar1()
Set aRange = Application.InputBox(prompt:="Выберите диапазон", Type:=8)
  If aRange Is Nothing Then
    MsgBox "Ошибка выбора диапазона"
  Else
  Application.ScreenUpdating = False
ReDim myar1(1 To aRange.Count, 1 To 112)
ReDim n(1 To 56)
 
For Each c In aRange
i = c.Interior.ColorIndex
n(i) = n(i) + 1
myar1(n(i), i * 2 - 1) = c.Row
myar1(n(i), i * 2) = c.Column
Next
End If
If UBound(myar1, 1) > 65536 Then
Range("C1000").Resize(UBound(myar1, 1) - 20000, UBound(myar1, 2)) = myar1
End If
'If UBound(myar1, 1) < 65536 Then
'Range("DK1000").Resize(UBound(myar1, 1), UBound(myar1, 2)) = myar1
'End If
 
Sheets("Лист2").Select
   Cells.Select
    Selection.ClearContents
    Sheets("Лист1").Select
   Range("A1000:DJ65536").Select
    Selection.Copy
    Sheets("Лист2").Select
   Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
Может подскажите,как грамотно разделить большой массив на 2 и более частей при выводе его на лист.?И как поступить если количество значений в одном из столбцов превысит 65536?
С уважением Olegoff.
0
3383 / 2080 / 684
Регистрация: 02.11.2012
Сообщений: 5,439
12.02.2016, 12:53 12
для начала массив не мешало бы почистить от пустых строк - это уменьшит размер массива. моих знаний мало чтобы сделать с наскоку.
0
1011 / 468 / 120
Регистрация: 27.02.2013
Сообщений: 1,348
12.02.2016, 13:09  [ТС] 13
Понятно.И за это спасибо.
P.S. Еще пробовал задать два массива,что бы первый считывал индексы с 1 по 28,а второй с29 по 56,но ничего не получилось,т.к. UBound(myar1, 1) остался таким же. Получается надо разбивать каким-то образом Входной диапазон на части.
0
3383 / 2080 / 684
Регистрация: 02.11.2012
Сообщений: 5,439
13.02.2016, 10:54 14
убрал пустоты в хвосте, осталось с разбивкой разобраться.
данные сразу заносятся на Лист2 начиная с ячейки А1
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub vvv()
Dim myar(), n(1 To 56) As Long, i As Long
Set aRange = Application.InputBox(prompt:="Выберите диапазон", Type:=8)
  If aRange Is Nothing Then
    MsgBox "Ошибка выбора диапазона"
  Else
  Application.ScreenUpdating = False
For Each c In aRange
i = c.Interior.ColorIndex
n(i) = n(i) + 1
If n(i) > m Then m = n(i): ReDim Preserve myar(1 To 112, 1 To m)
myar(c.Interior.ColorIndex * 2 - 1, n(i)) = c.Row
myar(c.Interior.ColorIndex * 2, n(i)) = c.Column
Next
End If
If UBound(myar, 2) < 65536 Then
Sheets("Лист2").Range("A1").Resize(UBound(myar, 2), UBound(myar, 1)) = WorksheetFunction.Transpose(myar)
Else
'.....
End If
Application.ScreenUpdating = True
End Sub
Добавлено через 7 минут
скорей всего нужно добавить строчку очистки листа перед внесением данных
Visual Basic
1
Sheets("Лист2").Cells.ClearContents
1
1011 / 468 / 120
Регистрация: 27.02.2013
Сообщений: 1,348
13.02.2016, 11:05  [ТС] 15
А мне кажется,что проще в конце разбить массив myar на два(myar1 и myar2).В первый занести данные до 65000,а во второй хвост до UBound.А затем выгрузить их последовательно на лист.
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
13.02.2016, 11:05

Заказываю контрольные, курсовые, дипломные работы и диссертации здесь.

Написать функцию, позволяющую в диапазоне ячеек MS Excel, выделенном пользователем, вычислить
Написать функцию, позволяющую в диапазоне ячеек MS Excel, выделенном пользователем, вычислить...

Напишите в среде Excel макрос, который в выделенном диапазоне ячеек должен выполнять заданные действия
Напишите в среде Excel макрос, который в выделенном диапазоне ячеек должен выполнять заданные...

Excel : Изменить на красный фон тех ячеек в выделенном диапазоне, которые пусты (не содержат информацию)
10. Excel : Изменить на красный фон тех ячеек в выделенном диапазоне, которые пусты (не содержат...

Код не работает на всем выделенном диапазоне, а останавливается после первого выполнения
Здравствуйте! Подскажите, пожалуйста, кому это интересно, почему скрипт не работает до конца...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
15
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.