Страницы: 1
RSS
VBA. Заполнение данных из одной таблицы в другую., Циклами в циклах и массивами.
 
Приветствую!

 Потихоньку осваиваю VBA, и решил написать, вроде как сначала показалось, незатейливый макрос, копирующий
данные из одной таблицы в другую согласно определённым условиям, но столкнулся с нехваткой знаний VBA
и общего понимания конструкции, как именно это реализовать.

...а поначалу вообще хотел через массивы всё сделать, так как хотелось высокой скорости работы макроса,
но с удивлением для себя обнаружил, что в VBA в массивах отсутствует поиск, подобный Find(). Да и как выяснилось, он бы тоже не особо помог. Нашёл некоторые готовые решения по поиску в массивах, но куда мне уж там, коли не смог даже в обычных циклах сделать.

 В общем, в файле-примере достаточно наглядно всё описал. Файл-пример обладает небольшим набором данных,
в оригинале их гораздо больше, поэтому и были мысли делать через массивы.
В файле уже начат макрос с обычными циклами, и закомментированы строки,
дальше которых уже не смог придумать, как сделать так, чтобы всё работало.

Гляньте, пожалуйста, а?..
Изменено: z-f-s - 18.09.2020 02:36:39
 
z-f-s, Если отбросить это условие:
Цитата
если встречается одно значение, и последующей строке ПУСТАЯ ячейка - то такая строка относится к тому же значению, что выше неё до тех пор, пока не встретится значение, отличное от искомого.
Можно решить формулой. Если интересует, прикрепляю вариант
 
см. вложение
Код
Sub FillB()
  Const t$ = "Авария! Исправьте данные!!!"
  Dim r&, rc&, a, b, c, d, k&()
  Set d = CreateObject("Scripting.Dictionary")
  rc = Cells(Rows.Count, 7).End(xlUp).Row
  a = Range(Cells(1, 8), Cells(rc, 7))
  For r = 1 To UBound(a)
    If d.exists(a(r, 1)) Then
      b = d(a(r, 1)): ReDim Preserve b(0 To UBound(b) + 1)
    Else
      ReDim b(0 To 1): b(0) = d.Count
    End If
    b(UBound(b)) = r: d(a(r, 1)) = b
  Next
  c = Range(Cells(1, 1), Cells(rc, 2)): ReDim k(0 To d.Count - 1)
  For r = 0 To UBound(k): k(r) = 1: Next
  For r = 1 To rc
    If Not d.exists(c(r, 1)) Then _
    MsgBox "A" & r & " = " & c(r, 1) & vbLf & _
    "неожиданное значение!?!", vbCritical, t: Exit Sub
    n = d(c(r, 1))(0)
    If k(n) > UBound(d(c(r, 1))) Then _
      MsgBox "А" & r & " = " & c(r, 1) & vbLf & _
      "лишнее значение!", vbCritical, t: Exit Sub
    c(r, 2) = a(d(c(r, 1))(k(n)), 2): k(n) = k(n) + 1
  Next
  Range(Cells(1, 1), Cells(rc, 2)) = c
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Александр П., спасибо, но нужно именно макросом. Эксель с ума сойдёт от кол-ва формул, работать с ним будет невозможно. Ігор Гончаренко, вау.. Класс! Только код вываливается на ошибке, когда встречает пустую ячейку в "A", но по условию
пустая ячейка в А является тем же значением, что выше найденное, равно как и ячейка с содержанием такого же значения...

В файле, в описании, строчки "если встречается одно значение, и в последующей строке содержится такое же точно значение, или же ПУСТАЯ ячейка - то такая строка относится к тому же значению, что выше неё до тех пор, пока не встретится значение, отличное от искомого." как раз подчёркивают важность этого момента. На листах с примерами изображены ситуации, когда изначально в "А" условные порядковые номера могут быть расположены именно в таком виде.
Изменено: z-f-s - 18.09.2020 11:59:34
 
просто вместо того чтобы лаконично и точно описать задачу вы были слишком сосредоточены на описании своего решения этой задачи
написано,
- что вы осваиваете VBA
- о массивах,
- о разочаровании с Find
- о количестве данных
- и еще о чем-то
нет только четкого описания задачи
код у вас есть, добавьте строку, поправьте несколько и все готово)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал:
просто вместо того чтобы лаконично и точно описать задачу вы были слишком сосредоточены на описании своего решения этой задачи
Да, есть такое, но саму задачу подробно описал в самом файле.

> код у вас есть, добавьте строку, поправьте несколько и все готово)

Спасибо огромное! Буду ковырять ))
Страницы: 1
Наверх