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

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

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

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

Купить рекламу на форуме - 42 тыс руб за месяц

Закрытая тема
Ваша тема закрыта, почему это могло произойти? Возможно,
Нет наработок или кода, если нужно готовое решение - создайте тему в разделе Фриланс и оплатите работу.
Название темы включает слова - "Помогите", "Нужна помощь", "Срочно", "Пожалуйста".
Название темы слишком короткое или не отражает сути вашего вопроса.
Тема исчерпала себя, помните, один вопрос - одна тема
Прочитайте правила и заново правильно создайте тему.
 
Опции темы Поиск в этой теме
Старый 10.01.2012, 01:51   #1
sweyle
 
Регистрация: 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. Причина: Описка
sweyle вне форума
Старый 10.01.2012, 02:15   #2
alex77755
Форумчанин
 
Аватар для alex77755
 
Регистрация: 14.02.2009
Сообщений: 753
По умолчанию

Загрузи всё в массив. сделай и вывали на лист одной строкой.
Записывать поячеечно всегда бывает медленно
помогу решить контрольные VB6, VBA (недорого)
Alex77755@mail.ru
alex77755 вне форума
Старый 10.01.2012, 02:59   #3
Казанский
Старожил
 
Аватар для Казанский
 
Регистрация: 31.12.2010
Сообщений: 2,133
По умолчанию

А так - в свободный столбец вставить возрастающий ряд чисел 1, 2, 3, ... (формула =СТРОКА()), отсортировать по этому столбцу по убыванию, удалить столбец?
Код:
Sub bb()
With ActiveSheet.UsedRange.Resize(, ActiveSheet.UsedRange.Columns.Count + 1)
    .Columns(.Columns.Count).Formula = "=ROW()"
    .Sort .Cells(1, .Columns.Count), xlDescending, Header:=xlNo
    .Columns(.Columns.Count).EntireColumn.Delete
End With
End Sub
Область данных не обязана начинаться с А1, перед ней могут быть пустые строки и столбцы.
И форматирование сохраняется.
exceleved@yandex.ru Яндекс.Деньги: 410011500007619

Последний раз редактировалось Казанский; 10.01.2012 в 09:43.
Казанский вне форума
Старый 10.01.2012, 12:08   #4
sweyle
 
Регистрация: 23.03.2011
Сообщений: 4
По умолчанию

Цитата:
Сообщение от alex77755 Посмотреть сообщение
Загрузи всё в массив. сделай и вывали на лист одной строкой.
Записывать поячеечно всегда бывает медленно
На счет скорости вы правы!, НО чтоб я знал как это делается!

Проблему вроде как решил, надо было, вот так записывать
Range(Cells(i, 1), Cells(i, n)).Value
sweyle вне форума
Старый 11.01.2012, 16:11   #5
wonder77
Новичок
Джуниор
 
Регистрация: 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
wonder77 вне форума
Старый 11.01.2012, 16:13   #6
wonder77
Новичок
Джуниор
 
Регистрация: 10.01.2012
Сообщений: 5
По умолчанию

Не могу сделать поиск так быстро. Это тоже самое что делали в задаче на поиск подматрицы в матрице. Только тут она должна начинаться на главной диагонали. и она будет квадратной.
wonder77 вне форума
Старый 11.01.2012, 17:06   #7
wonder77
Новичок
Джуниор
 
Регистрация: 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
wonder77 вне форума
Старый 11.01.2012, 17:19   #8
wonder77
Новичок
Джуниор
 
Регистрация: 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
wonder77 вне форума
Старый 11.01.2012, 17:33   #9
wonder77
Новичок
Джуниор
 
Регистрация: 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.
wonder77 вне форума
Старый 11.01.2012, 21:11   #10
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Сообщений: 6,856
По умолчанию

wonder77, не понял, к чему в этой теме ваши сообщения.
Закрою тему, чтобы вы больше не постили сюда непонятно что и зачем.
EducatedFool вне форума
Закрытая тема


Купить рекламу на форуме - 42 тыс руб за месяц

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
В чём может быть ошибка? 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