Excel это не сложно
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
21.05.2024, 10:37:24

Войти
Название темы должно отражать её содержание.
Темы типа "ПОМОГИТЕ!!!", "Срочно!", "Не получается сделать", "Нужна помощь" и т.п. будут удаляться без объяснения причин
33 266 Сообщений в 5 461 Тем от 6 769 Пользователей
Последний пользователь: Fortuna
*
Перейти на сайт Хитрости Надстройка MulTEx Обучающие тренинги Наша группа ВКонтакте
Правила форума Начало Помощь Поиск Календарь Войти Регистрация Выйти
+  Excel это не сложно
|-+  Основные форумы
| |-+  Вопросы по Excel и VBA
| | |-+  VBA. ошибка в коде при написании макроса для генератора путевых листов.
Страниц: [1]   Вниз
Печать
Автор Тема: VBA. ошибка в коде при написании макроса для генератора путевых листов.  (Прочитано 2426 раз)
0 Пользователей и 1 Гость смотрят эту тему.
axlnik
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 3


Просмотр профиля E-mail
« : 10.03.2023, 17:53:01 »

Добрый день, я  в VBA ноль, подсмотрел в разных источниках и  написал макрос, но написал с ошибками, а так как не понимаю в VBA  то и ошибку найти не могу. Помогите пожалуйста.
Что хотел сделать: 
генератор маршрутных листов
на входе в макрос километраж, количество дней, список адресов с приоритетами и расстоянием до них.
На выходе список адресов по дням с километражом.

Как пытался вычислить:
взять километраж "killometrag" и разделить его на количество дней "day", чтобы цифры были не одинаковыми рандомно прибавить или отнять рандомное число, которое будет прописано в ячейке "разброс".
Затем проверить, что сумма километров за эти дне не превысит общий километраж из ячейки  "killometrag".
Так я получу сколько километров в день проехали.
Затем я беру из массива "rastoyniy" рандомные числа и проверяю, чтобы сумма этих чисел была равна километражу за день. Числа берутся не совсем рандомно, у каждого числа есть вес, который указан в третьем столбце массива, чем выше число тем выше приоритет этой ячейки попасть в выборку, чем у других.
Если сумма больше километражу за день, цикл начинается по новой.
Получив нужную сумму я извлекаю адреса строк, вписываю в ячейку с именем "spisok". Так я повторяю до тех пор пока не заполню строки по количеству дней.

Код: (vb)
Sub RandomCells()
    Dim day As Integer 'переменная для хранения значения ячейки "day"'
    Dim kalendar() As Variant 'объявляем массив kalendar'
    Dim rastoyniy() As Variant 'объявляем массив rastoyniy'
    Dim killometrag As Integer 'переменная для хранения значения ячейки "killometrag"'
    Dim razbros As Integer 'переменная для хранения значения ячейки "razbros"'
    Dim mini_rashojdenie As Integer 'переменная для хранения значения ячейки "mini_rashojdenie"'
   

    'задаем значения переменных'
   ' Получаем значения из ячеек
    day = Range("day").Value
    killometrag = Range("killometrag").Value
    razbros = Range("razbros").Value
    mini_rashojdenie = Range("mini_rashojdenie").Value
   
    ' Создаем массив kalendar
    ReDim kalendar(1 To day, 1 To 3)
   
   ' Массив kalendar выведем в ячейку spisok
    Range("spisok").Resize(dayCount, 1).Value = kalendar
   
   ' Заполняем первый столбец массива kalendar рандомными числами
    Dim i As Integer
    Dim summa As Integer
    For i = 1 To day
        kalendar(i, 1) = Int(Rnd() * (killometrag/day)) + 1 'здесь можно изменить диапазон случайных чисел
        summa = summa + kalendar(i, 1)
    Next i
   
    ' Выполняем проверку на разброс значений в первом столбце массива kalendar
    Dim raznost As Integer
    Dim r As Integer
    Dim p As Integer
    Dim modified As Boolean

While True
    raznost = 0
    modified = False
    For r = 1 To day - 1
        For p = r + 1 To day
            If Abs(kalendar(r, 1) - kalendar(p, 1)) > razbros Then
                raznost = raznost + 1
                kalendar(r, 1) = Int(Rnd() * killometrag) + 1
                modified = True
            End If
        Next p
    Next r
   
    ' Если разброс удовлетворительный или не было изменений, выходим из цикла
    If raznost = 0 Or Not modified Then
        Exit While
    End If
Wend
   
   ' Создаем массив rastoyniy
    Dim last_row As Integer
    last_row = Cells(Rows.Count, 1).End(xlUp).Row
    ReDim rastoyniy(1 To last_row, 1 To 3)
    For i = 1 To last_row
        rastoyniy(i, 1) = Cells(i, 1).Value
        rastoyniy(i, 2) = Cells(i, 2).Value
        rastoyniy(i, 3) = Cells(i, 3).Value
    Next i
   
    ' Выбираем случайную ячейку из массива rastoyniy вторым столбцом
    Dim rast_summa As Integer
    rast_summa = 0
    Dim current_row As Integer
    current_row = Int(Rnd() * last_row) + 1
    Do While rast_summa + rastoyniy(current_row, 2) <= kalendar(1, 1) - mini_rashojdenie
    ' Заполняем ячейки массива kalendar соответствующими значениями
    kalendar(1, 2) = rastoyniy(current_row, 1)
    kalendar(1, 3) = kalendar(1, 3) + rastoyniy(current_row, 2)
    rast_summa = rast_summa + rastoyn
    ' выбираем ячейку из массива rastoyniy
    Set vybor = rastoyniy.Cells(intVybor, 1)
    ' увеличиваем счетчик выбора данной ячейки
    vybor.Offset(0, 2).Value = vybor.Offset(0, 2).Value + 1
       
    ' добавляем выбранное значение в массив kalendar
    kalendar(intI, 1) = vybor.Offset(0, 1).Value
    kalendar(intI, 2) = vybor.Offset(0, 2).Value
       
    ' добавляем значение в третий столбец kalendar
    kalendar(intI, 3) = kalendar(intI, 3) + vybor.Offset(0, 2).Value
       
    ' вычисляем разницу между последним выбранным числом
    ' и суммой чисел в массиве kalendar
    intRaznica = km - WorksheetFunction.Sum(Columns(2).Resize(intI, 1))
       
      если сумма чисел в массиве превышает km - mini_rashojdenie
    ' то начинаем выбор с начала
    If intRaznica < mini_rashojdenie Then
        intI = 0
        Set kalendar = Nothing
        Set kalendar = CreateObject("System.Collections.ArrayList")
        kalendar.Capacity = day
        GoTo start_kalendar
    End If
       
        ' переходим к следующей строке в массиве kalendar
        intI = intI + 1
    Next intI
   
       ' выводим значения из массива kalendar в лист
        Range("K20:M" & day + 1).Value = kalendar.ToArray()
   
End Sub
Записан
Дмитрий Щербаков(The_Prist)
Администратор
Ветеран
*****

Репутация: +485/-0
Офлайн Офлайн

Сообщений: 5 838



Просмотр профиля WWW
« Ответ #1 : 10.03.2023, 18:37:03 »

Если честно - здесь не ошибки искать надо, а по ходу переписывать код...Но если уж по ошибкам пройтись:
1. Exit While - что это и откуда взялось? Нет такого в VBA. Для выхода используется Exit Do.
2. Есть строка Do While rast_summa + rastoyniy(current_row, 2) <= kalendar(1, 1) - mini_rashojdenie. Но вот где к ней закрывающий Loop? Нигде. И где должен быть непонятно.
3. В самом конце кода есть строка Next intI. Но к чему она? К ней просто нет никакого For. И  где он должен быть - тоже непонятно. Даже сама переменная intI нигде не объявлена и не имеет начального значения перед применением. Можно было бы подумать, что начальное значение должно быть 0, но она впервые используется в массиве kalendar, который объявлен с нижней границей 1, а значит попытка использовать переменную со значением 0 выдаст ошибку. Видимо, For для неё должен быть где-то в начале кода.
4. Переменная kalendar объявлен изначально как массив, но далее используется и как массив и как объект ArrayList. Тоже будет ошибка сразу на строке Set kalendar = Nothing.
Может есть и еще ошибки - не стал анализировать этот код дальше, т.к. смысла нет.

Именно из-за всего этого я и написал, что здесь надо все писать с нуля, т.к. исправление ошибок вряд ли что-то даст.
« Последнее редактирование: 10.03.2023, 18:41:59 от Дмитрий Щербаков(The_Prist) » Записан

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Пункты приёма Спасибов:    -41001332272872  -R298726502453
axlnik
Новичок
*

Репутация: +0/-0
Офлайн Офлайн

Сообщений: 3


Просмотр профиля E-mail
« Ответ #2 : 13.03.2023, 12:51:39 »

Дмитрий спасибо большое, извините, что Вам пришлось ковыряться в недокоде, искренне верил, что у меня что то получается, отдельно пару фрагментов работало, а когда попытался соединить в конечный код, вышла такая лажа.
Записан
Страниц: [1]   Вверх
Печать
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2011, Simple Machines Valid XHTML 1.0! Valid CSS!
Яндекс.Метрика Рейтинг@Mail.ru