|
|
Регистрация Восстановить пароль |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
Нет наработок или кода, если нужно готовое решение - создайте тему в разделе Фриланс и оплатите работу. Название темы включает слова - "Помогите", "Нужна помощь", "Срочно", "Пожалуйста". Название темы слишком короткое или не отражает сути вашего вопроса. Тема исчерпала себя, помните, один вопрос - одна тема Прочитайте правила и заново правильно создайте тему. |
|
Опции темы | Поиск в этой теме |
10.01.2012, 01:51 | #1 |
Регистрация: 23.03.2011
Сообщений: 4
|
Почему не работает код, где может быть ошибка
Есть такой код, работает, но есть недостаток когда данных стало очень много стал очень медленно работать, я решил сделать переворот не по одной ячейке, а по строчке...
Sub Perevorot() Application.ScreenUpdating = False Dim m As Integer Dim n As Integer Dim i As Long Dim k As Long Dim temp As Variant temp = "" m = Columns("A").Find(What:="*", LookIn:=xlValues, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 n = Rows(1).Find(What:="*", LookIn:=xlValues, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column + 1 For i = 2 To Int(m / 2) For k = 1 To n temp = Cells(i, k) Cells(i, k) = Cells(m - i + 1, k) Cells(m - i + 1, k) = temp Next Next End Sub /----------------------------------------------------------------------/ Вот что у меня получилось, код работает, но на половину.... Sub Perevorot() Application.ScreenUpdating = False Dim m As Integer Dim n As Integer Dim i As Long Dim k As Long Dim temp As Variant temp = "" m = Columns("A").Find(What:="*", LookIn:=xlValues, SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 n = Rows(1).Find(What:="*", LookIn:=xlValues, SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column + 1 For i = 2 To Int(m / 2) temp = Range(Cells(i, 1), Cells(i, 8)) Range(Cells(i, 1), Cells(i, 8)) = Range(Cells(m - i + 1, 1), Cells(m - i + 1, 8)) ' ---------------------------------------------------------------------- Когда программа проходит это место в верху таблицы строчка должна замениться на строчку с низа, а она меняется на пустую строчку! ---------------------------------------------------------------------- Range(Cells(m - i + 1, 1), Cells(m - i + 1, 8)) = temp Next End Sub Помогите пожалуйста разобраться с такой проблемой. Последний раз редактировалось sweyle; 10.01.2012 в 01:53. Причина: Описка |
10.01.2012, 02:15 | #2 |
Форумчанин
Регистрация: 14.02.2009
Сообщений: 753
|
Загрузи всё в массив. сделай и вывали на лист одной строкой.
Записывать поячеечно всегда бывает медленно
помогу решить контрольные VB6, VBA (недорого)
Alex77755@mail.ru |
10.01.2012, 02:59 | #3 |
Старожил
Регистрация: 31.12.2010
Сообщений: 2,133
|
А так - в свободный столбец вставить возрастающий ряд чисел 1, 2, 3, ... (формула =СТРОКА()), отсортировать по этому столбцу по убыванию, удалить столбец?
Код:
И форматирование сохраняется.
exceleved@yandex.ru Яндекс.Деньги: 410011500007619
Последний раз редактировалось Казанский; 10.01.2012 в 09:43. |
10.01.2012, 12:08 | #4 |
Регистрация: 23.03.2011
Сообщений: 4
|
|
11.01.2012, 16:11 | #5 |
Новичок
Джуниор
Регистрация: 10.01.2012
Сообщений: 5
|
'Ячейки в экселе
'5 '6 '1 2 '2 3 '1 3 '4 5 '1 5 '3 4 Private Sub cbDoTask10_Click() Dim m, n, i, j, k, tmp, x, y As Integer n = ActiveSheet.Cells(1, 1).Text 'количество знакомых k = ActiveSheet.Cells(2, 1).Text 'количество пар друзей Dim a() As Integer ReDim a(1 To n, 1 To n) As Integer 'Матрица связей Dim b() As Integer ReDim b(1 To n) As Integer For i = 1 To n 'Заполняем матрицу a(i, i) = 1 Next i For i = 1 To k a(ActiveSheet.Cells(2 + i, 1).Value, ActiveSheet.Cells(2 + i, 2).Value) = 1 '1-й друг 2-му a(ActiveSheet.Cells(2 + i, 2).Value, ActiveSheet.Cells(2 + i, 1).Value) = 1 '2-й друг 1-му Next i For i = 1 To n For j = i To n 'поиск максимальной квадратной подматрицы состоящей из 1 и начинающейся на главной диагонали Next j Next i TextBox1.Value = m 'вывод наибольшего состава команды мэра 'For i = 1 To z 'TextBox2.Value = TextBox2.Value + c(i) 'вывод состава команды мэра в возрастающем порядке их номеров. 'Next i End Sub |
11.01.2012, 16:13 | #6 |
Новичок
Джуниор
Регистрация: 10.01.2012
Сообщений: 5
|
Не могу сделать поиск так быстро. Это тоже самое что делали в задаче на поиск подматрицы в матрице. Только тут она должна начинаться на главной диагонали. и она будет квадратной.
|
11.01.2012, 17:06 | #7 |
Новичок
Джуниор
Регистрация: 10.01.2012
Сообщений: 5
|
'Ячейки в экселе
'5 '6 '1 2 '2 3 '1 3 '4 5 '1 5 '3 4 Private Sub cbDoTask10_Click() Dim m, n, i, j, k, tmp, z, q As Integer n = CInt(ActiveSheet.Cells(1, 1).Value) 'количество знакомых k = CInt(ActiveSheet.Cells(2, 1).Value) 'количество пар друзей Dim a() As Integer ReDim a(1 To n, 1 To n) As Integer 'Матрица связей Dim b() As Integer 'массив максимальных значений ReDim b(1 To n) As Integer For i = 1 To n 'Заполняем матрицу a(i, i) = 1 Next i For i = 1 To k a(ActiveSheet.Cells(2 + i, 1).Value, ActiveSheet.Cells(2 + i, 2).Value) = 1 '1-й друг 2-му a(ActiveSheet.Cells(2 + i, 2).Value, ActiveSheet.Cells(2 + i, 1).Value) = 1 '2-й друг 1-му Next i Dim max_i, max_k, max_s, min_x As Integer max_i = 1 For i = 1 To n 'проходим по главной диагонали k = i Do While (k <= n) And (a(k, i) = 1) 'получаем последний элемент не равный 0 (номер конца подматрицы) k = k + 1 If k > n Then Exit Do End If Loop k = k - 1 min_x = k + 1 For z = i To k 'проходим по выделенной подматрице и ищем проверяем вся ли она состоит из 1 For q = i To k If a(z, q) = 0 Then ' если нашли 0 то уменьшаем размер подматрицы до чтобы в нее не входил 0 If min_x > q Then min_x = q End If End If Next q Next z If (min_x = k + 1) Then b(i) = (k - i + 1) 'записываем размер макс.подматрицы состоящей из 1ц которую нашли начиная с элемента a(i,i) Else k = min_x - 1 ' b(i) = (min_x - i) End If If b(i) >= b(max_i) Then 'находим макс. подматрицу и записываем номер элемента в max_i с которого будет начинаться максимальная подматрица max_i = i max_k = k End If Next i TextBox1.Value = b(max_i) 'вывод наибольшего состава команды мэра For i = max_i To max_k TextBox2.Value = TextBox2.Value + " " + CStr(i) 'вывод состава команды мэра в возрастающем порядке их номеров. Next i End Sub |
11.01.2012, 17:19 | #8 |
Новичок
Джуниор
Регистрация: 10.01.2012
Сообщений: 5
|
'Ячейки в экселе
'5 '6 '1 2 - 1й дружит со вторым '2 3 - 2-й с 3-м '1 3 - 1-й с 3-м '4 5 '1 5 '3 4 Private Sub cbDoTask10_Click() Dim m, n, i, j, k, tmp, z, q As Integer n = CInt(ActiveSheet.Cells(1, 1).Value) 'количество знакомых k = CInt(ActiveSheet.Cells(2, 1).Value) 'количество пар друзей Dim a() As Integer ReDim a(1 To n, 1 To n) As Integer 'Матрица связей Dim b() As Integer 'массив максимальных значений ReDim b(1 To n) As Integer For i = 1 To n 'Заполняем матрицу a(i, i) = 1 Next i For i = 1 To k a(ActiveSheet.Cells(2 + i, 1).Value, ActiveSheet.Cells(2 + i, 2).Value) = 1 '1-й друг 2-му a(1,2)=1 a(ActiveSheet.Cells(2 + i, 2).Value, ActiveSheet.Cells(2 + i, 1).Value) = 1 '2-й друг 1-му a(2,1)=1 Next i Dim max_i, max_k, max_s, min_x As Integer max_i = 1 For i = 1 To n 'проходим по главной диагонали k = i Do While (k <= n) And (a(k, i) = 1) 'получаем последний элемент не равный 0 (номер конца подматрицы) k = k + 1 If k > n Then Exit Do End If Loop k = k - 1 min_x = k + 1 For z = i To k 'проходим по выделенной подматрице и ищем проверяем вся ли она состоит из 1 For q = z To k If a(z, q) = 0 Then ' если нашли 0 то уменьшаем размер подматрицы до чтобы в нее не входил 0 If min_x > q Then min_x = q End If End If Next q Next z If (min_x = k + 1) Then b(i) = (k - i + 1) 'записываем размер макс.подматрицы состоящей из 1ц которую нашли начиная с элемента a(i,i) Else k = min_x - 1 ' b(i) = (min_x - i) End If If b(i) >= b(max_i) Then 'находим макс. подматрицу и записываем номер элемента в max_i с которого будет начинаться максимальная подматрица max_i = i max_k = k End If Next i TextBox1.Value = b(max_i) 'вывод наибольшего состава команды мэра For i = max_i To max_k TextBox2.Value = TextBox2.Value + " " + CStr(i) 'вывод состава команды мэра в возрастающем порядке их номеров. Next i End Sub |
11.01.2012, 17:33 | #9 |
Новичок
Джуниор
Регистрация: 10.01.2012
Сообщений: 5
|
В общем чтобы найти максильное количество строим матрицу отношений. Там где дружба будет 1. На главной диагонали всегда 1. Потому что
каждый друг сам себе. ПОтом чтобы найти максимальное количество человек в команде где каждый будет дружить с каждым, это значит нужно найти максимальную подматрицу из 1-ц. То есть в ней все будут дружить со всеми. Мы начинаем искать ей с главной диагонали.То есть эта подматрица будет начинаться с эл. а(1,1) или а(2,2) и тд. И проверям ищем в этой строке первый 0. Это будет граница подматрицы и проверяем вся ли она сост. из 1. Если встреим 0 раньше чем конец мантрицы. то значит уменьшим её до этого нуля. ПОтом когда проверили. Записываем в массив b(i) размер найденной подматрицы из 1. То есть если она была размера 3х3 и начиналась с элемента а(1.1). то мы пишем в массив b(1)=3. Потом ищем для каждого элемента на гл. диаг. и записываем в b(i) значения найденных подматриц. А потом сравниваем значения массива b. и ищем в нем максимальное. это и будет ответ. то есть это и будет количество членов команды мэра. А потом выводим номер знакомых которые будут в этой команде. Начальный номер у нас будет. Это будет идекс в массиве b(). А конечный мы там хранили в переменной max_k. либо конечный будет = индекс массива b + размер матрицы-1. |
11.01.2012, 21:11 | #10 |
Программист VBA
СуперМодератор
Регистрация: 13.07.2008
Сообщений: 6,858
|
wonder77, не понял, к чему в этой теме ваши сообщения.
Закрою тему, чтобы вы больше не постили сюда непонятно что и зачем. |
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
В чём может быть ошибка? | Lindemann66 | Qt и кроссплатформенное программирование С/С++ | 1 | 18.08.2011 13:52 |
Где может быть ошибка? | Tricko | C# (си шарп) | 3 | 26.06.2011 12:42 |
кто может объяснить,почему на моем компе программа работает на других нет?код в Delphi | Symba | Общие вопросы Delphi | 1 | 24.03.2011 01:03 |
не работает ехе файл в visual C++. В чем может быть ошибка? | katya-vesnushka | Visual C++ | 1 | 08.11.2010 22:00 |
где может быть ошибка? | maksim_serg | Microsoft Office Excel | 2 | 21.04.2010 10:42 |