Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.67/3: Рейтинг темы: голосов - 3, средняя оценка - 4.67
0 / 0 / 0
Регистрация: 10.01.2014
Сообщений: 7
1

Подстановка шаблонов по масками

28.01.2015, 16:39. Просмотров 524. Ответов 9
Метки нет (Все метки)


Добрый день товарищи.
Столкнулся я с одной задачей, прошу совета у вас.
Есть таблица в которой я создаю наряды - указываю некоторые параметры и расставляю цены. (прикрепил)
После распечатываю и отдаю в работу.
Все наряды находятся в диапазоне (A13-H326) - их может быть до 25 нарядов.
на листе 1 то как наряды выглядит изначально (когда ко мне попадают)
на листе 2 то как они выглядят готовыми к печати

У каждого наряда есть ячейка с техническими параметрами (наименование изделия и размеры - B16, B25 и т.д.)

Задача - хочу сделать макрос который будет по первым нескольким символам из этих ячеек подбирать к ним ценники-шаблоны которые находятся в диапазоне (O3-T9) и подставлял их в каждый наряд.

Как это происходит: Информация из ячейки с тех.парам. (B16)
ФК-02 (9 ) F5
540х540-500
Подходящий к нему шаблон - ФК находится в диапазоне (P5-Q9)

Раньше все нужные макросы я писал через макро рекодер, но тут я столкнулся с тем что не могу произвести поиск именно по первым двум символам (как я себе это представлял) ну и + вставка шаблонов не осуществима.

Подскажите пожалуйста как это сделать.
0
Вложения
Тип файла: xlsx Наряд1.xlsx (16.0 Кб, 7 просмотров)
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
28.01.2015, 16:39
Ответы с готовыми решениями:

Дело с масками
Столкнулся тут с очень простой (по чутью) и в то же время с нерешаемой уже неделю проблемой: Нужно...

Работа с побитовыми операторами и масками
есть программа, она заменяет в шестнадцатеричном числе все нечетные цифры нулями. при написании...

Объединить 2 подсети с разными масками
Всех приветствую. Я первый день на работе в кресле сисадмина и уже столкнулся с проблемой. До меня...

Подстановка, зависимые ячейки, подстановка по условию
Доброго времени суток. Предисловие! Можно не читать. Около недели назад начал разрабатывать...

9
5349 / 1413 / 332
Регистрация: 23.12.2010
Сообщений: 2,081
Записей в блоге: 1
29.01.2015, 11:11 2
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Naryad()
    Dim i&, j&, A, LastRow&
    A = Range([A3], Cells(3, ActiveSheet.UsedRange.Columns.Count)).Value
    LastRow = Cells(Columns.Count, 2).End(xlUp).Row
    For i = 5 To LastRow
        If Cells(i - 1, 2) = "Вид заказа" Then
            For j = 12 To UBound(A, 2)
                If A(1, j) <> "" And A(1, j) = Left(Cells(i, 2), Len(A(1, j))) Then
                    Range(Cells(i, 4), Cells(i + 4, 5)).Formula = Range(Cells(5, j + 1), Cells(9, j + 2)).Formula
                End If
            Next j
        End If
    Next i
End Sub
1
0 / 0 / 0
Регистрация: 10.01.2014
Сообщений: 7
29.01.2015, 14:23  [ТС] 3
KoGG спасибо большое, работает. Но есть неточности.

1
После подстановки шаблона, формулы остаются к старым ячейкам.
То есть шаблон ФК стоял в колонках O, P, Q и в итоге после подстановки в наряд в колонки D, E в формулах остаются значения на просчет O, P, Q.

2
шаблонов в примере два, но на самом деле их около 10, все однообразны. Насколько я понял по коду, то вы прописывали условие для каждого шаблона?
0
5349 / 1413 / 332
Регистрация: 23.12.2010
Сообщений: 2,081
Записей в блоге: 1
29.01.2015, 14:28 4
1.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Naryad()
    Dim i&, j&, A, LastRow&
    A = Range([A3], Cells(3, ActiveSheet.UsedRange.Columns.Count)).Value
    LastRow = Cells(Columns.Count, 2).End(xlUp).Row
    For i = 5 To LastRow
        If Cells(i - 1, 2) = "Вид заказа" Then
            For j = 12 To UBound(A, 2)
                If A(1, j) <> "" And A(1, j) = Left(Cells(i, 2), Len(A(1, j))) Then
                    Range(Cells(i, 4), Cells(i + 4, 5)).FormulaR1C1 = Range(Cells(5, j + 1), Cells(9, j + 2)).FormulaR1C1
                End If
            Next j
        End If
    Next i
End Sub
2. Да.
2
0 / 0 / 0
Регистрация: 10.01.2014
Сообщений: 7
29.01.2015, 14:55  [ТС] 5
Моя ошибка, нужно было сразу все шаблоны указать, включите в код пожалуйста и остальные (прикрепил)
0
Вложения
Тип файла: xlsx Наряд2.xlsx (17.9 Кб, 3 просмотров)
0 / 0 / 0
Регистрация: 10.01.2014
Сообщений: 7
29.01.2015, 15:09  [ТС] 6
Еще если вас не затруднит, поясните мне, для будущих коррективов кода, как именно мне вносить новые шаблоны?
0
5349 / 1413 / 332
Регистрация: 23.12.2010
Сообщений: 2,081
Записей в блоге: 1
29.01.2015, 15:14 7
Я написал "Да" в смысле не для каждого из двух, а любого количества шаблонов.
Никаких изменений вносить не надо.
Стоило попробовать.
1
6068 / 1312 / 195
Регистрация: 12.12.2012
Сообщений: 1,024
29.01.2015, 15:26 8
Здравствуйте, glc,
Предлагаю вариант, работающий при условии, что заголовки всех новых шаблонов находятся на одном уровне (уровне 4-ой строки).

А высота шаблонов может быть любой (от 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
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
'Процедура для поиска информации в диапазоне rngToSeek по ключевому слову или фразе keyword.
'Найденные результаты заносятся в массив results, а их количество - в переменную resultCount.
Sub KeywordSearch(ByVal keyword As String, ByVal rngToSeek As Range, ByVal offsetX As Long, ByVal offsetY As Long, ByRef results() As String, ByRef resultCount As Long, Optional ByVal excludeAddr As String)
    Dim rngFirstFind As Range, rngFind As Range, maxSize As Long
    Set rngFirstFind = rngToSeek.Find(keyword)
    If rngFirstFind Is Nothing Then
        Exit Sub
    Else
        Set rngFind = rngFirstFind
        maxSize = 1
        ReDim results(0 To 1, 0 To maxSize - 1) As String
        Do
            If rngFind.Address <> excludeAddr Then
                results(0, resultCount) = rngFind.Offset(offsetX, offsetY)
                results(1, resultCount) = rngFind.Address
                resultCount = resultCount + 1
                If resultCount = maxSize Then
                    maxSize = 2 * maxSize
                    ReDim Preserve results(0 To 1, 0 To maxSize - 1) As String
                End If
            End If
            Set rngFind = rngToSeek.Find(keyword, rngFind)
        Loop Until rngFind.Address = rngFirstFind.Address
    End If
End Sub
Sub CopyPrices()
    Dim orders() As String, prices() As String, orderCount As Long, priceCount As Long
    Dim i As Long, j As Long, maxRows As Long, rng As Range
    'Осуществляем поиск в столбце B документа по ключевой фразе "Вид заказа".
    KeywordSearch "Вид заказа", Columns(2), 1, 0, orders, orderCount
    If orderCount = 0 Then
        MsgBox "Нет заказов."
        Exit Sub
    End If
    'Осуществляем поиск в строке №4 документа, за исключением ячейки D4, по ключевому слову "Розценка".
    KeywordSearch "Розценка", Rows(4), -1, -1, prices, priceCount, "$D$4"
    If priceCount = 0 Then
        MsgBox "Нет ценников."
        Exit Sub
    End If
    maxRows = Cells.Rows.Count
    Application.ScreenUpdating = False
    'Перебираем все сочетания каждого элемента одного массива с элементом другого и ищем совпадения.
    For i = 0 To priceCount - 1
        For j = orderCount - 1 To 0 Step -1
            If InStr(orders(0, j), prices(0, i)) Then
                'Если найдено частичное совпадение, копируем формулы из ценников в наряд.
                Set rng = Range(prices(1, i))
                Range(rng, Cells(maxRows, rng.Column + 1).End(xlUp)).Copy
                Range(orders(1, j)).Offset(, 2).PasteSpecial xlPasteFormulas
                'Удаляем заполненный наряд из списка нарядов, которые нужно перебирать.
                orders(0, j) = orders(0, orderCount - 1)
                orders(1, j) = orders(1, orderCount - 1)
                orderCount = orderCount - 1
            End If
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

С уважением,
Аксима
Добавлено через 3 минуты
P.S. KoGG, как всегда на высоте - коротко и четко! Молодец.
2
0 / 0 / 0
Регистрация: 10.01.2014
Сообщений: 7
29.01.2015, 16:30  [ТС] 9
KoGG
Я вас недопонял. Все работает. Спасибо вам огромное

Аксима
И вам большое спасибо, тоже все рабоатет
0
Заблокирован
29.01.2015, 16:49 10
хех.. вы еще других невидели..
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
29.01.2015, 16:49

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

Ячейки в одном столбце, но с разными масками
В продолжение темы(когда-то спрашивала про ячейки разной ширины в одном столбце, решили что все...

Соединение двух сетей с различными адресами и масками
Здравствуйте. Столкнулся с некоторой задачей, справиться с которой мне мои знания и опыт не...

В разделе "редактор шаблонов" в таблице нет файлов шаблонов
Привет, помогите с проблемой в движке DLE, в разделе редактор шаблонов в таблице нет файлов шаблона...

С++, создание шаблонов
Задание по C++ - создание шаблонов, помогите! Создать шаблон некоторого целевого класса А,...


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

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

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