Страницы: 1
RSS
Выпадающий список, который проставляет всю строку значений определенный образом
 
Уважаемые профи ексель, помогите! Я отблагодарю.
Файл используется для того, чтобы проставлять характеристики товарам для пром и опенкарт.
Есть 2 подзадачи.

1. (см файл "1. Все х-ки.xlsx")

Есть 2 идентификатора ID категории товара и  ID характеристики товара.
Работа производится на 1-м листе "Товары". В колонке А из выпадающего списка при выборе категории должна проставиться вся строка значений
Название_ХарактеристикиИзмерение_Характеристики
для данной группы товаров.

2. Конвертировать выделенные строки полученного результата в формат опенкарт с колонками как в файле "2. Х-ки опенкарт.xlsx" Заполнить только колонки выделенные желтым

Я отблагодарю за работу (кто возьмется, укажите в начале, сколько Вы хотите). Нахожусь в Украине, не сталкивался с оплатой в Россию, прошу подсказать , если знаете, как это сделать.
Изменено: Максим Николаевич - 09.06.2021 14:47:33
 
Цитата
Максим Николаевич написал:
Название_ХарактеристикиИзмерение_Характеристикидля данной группы товаров.
Таблица "Группа товаров-Название характеристики" есть?
 
Они разнесены на листах categry id и   atribute id
 
Тогда так. Какое значение нужно вывести в 'Товары '!D2?
 
Название_Характеристики Измерение_Характеристики Значение_Характеристики
вот эти 3 столбца нужно заполнить, повторяя столько раз, сколько есть характеристик во вкладке "Atribut ID-category_id"

На листе "товары": Категория выбирается из выпадающего списка. Код товара и наименование заполняется вручную, остальные столбцы должен заполнить скрипт в соответствии с выбранной категорией из списка
Изменено: vikttur - 09.06.2021 17:48:39
 
Цитата
Максим Николаевич написал:
Название_ХарактеристикиИзмерение_ХарактеристикиЗначение_Хара­ктеристикивот эти 3 столбца нужно заполнить, повторяя столько раз, сколько есть характеристик во вкладке "Atribut ID-category_id"
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Columns(1)) Is Nothing Then
            If Target.Row > 1 Then
                Range(Cells(Target.Row, 4), Cells(Target.Row, Columns.Count)).ClearContents
                If Target.Value <> "" Then
                    FillHar Target
                End If
            End If
        End If
    End If
End Sub

Sub FillHar(ByVal Target As Range)
    Dim y As Long
    On Error Resume Next
    y = WorksheetFunction.Match(Target.Value, Sheets("category_id").Columns(2), 0)
    On Error GoTo 0
    If y > 0 Then
        Dim x As Integer
        On Error Resume Next
        x = WorksheetFunction.Match(Sheets("category_id").Cells(y, 1).Value, Sheets("Atribut ID-category_id").Rows(1), 0)
        If x = 0 Then x = WorksheetFunction.Match(CStr(Sheets("category_id").Cells(y, 1).Value), Sheets("Atribut ID-category_id").Rows(1), 0)
        On Error GoTo 0
        If x > 0 Then
            With Sheets("Atribut ID-category_id")
                y = .Cells(1, x).End(xlDown).Row
                y = y - 1
            End With
            If y > 1 And y < Columns.Count / 3 - 4 Then
                Dim arr As Variant
                ReDim arr(1 To 1, 1 To 3 * y)
                For y = 1 To UBound(arr, 2) Step 3
                    arr(1, y + 0) = "Название_Характеристики"
                    arr(1, y + 1) = "Измерение_Характеристики"
                    arr(1, y + 2) = "Значение_Характеристики"
                Next
                Target.Cells(1, 4).Resize(1, UBound(arr, 2)) = arr
            End If
        End If
    End If
End Sub
 
ни фига не понятно
Внятней опишите порядок
Выбрали из списка "Светодиодный неон"
Ввели код "1012526"
Дальше-то что? откуда берётся Неон 54 5 м
Его нет ни в одной книге кроме как на листе "Товары"
нахожусь в Украине
 
МатросНаЗебре , простите,  мой уровень знания ексель такой, что я так и не смог вставить тот макрос, чтобы он работал. Точнее макрос я вставил, но он не отображается в спис ке всех макросов Не можете ли вы прислать уже готовый файл с макросом, пожалуйста?

Цитата
Александр Моторин написал: Внятней опишите порядок
На листе "товары": Категория выбирается из выпадающего списка. Код товара и наименование заполняется вручную, остальные столбцы должен заполнить скрипт в соответствии с выбранной категорией из списка
Изменено: vikttur - 09.06.2021 17:50:06
 
Цитата
Максим Николаевич написал:
я так и не смог вставить тот макрос
Правой кнопкой на ярлычке листа - Исходный текст
В появившееся окно вставляете код с форума.

Я думаю, бесполезно спрашивать третий раз, откуда макрос должен взять данные. Можно и в третий раз услышать:
Цитата
Максим Николаевич написал:
остальные столбцы должен заполнить скрипт в соответствии с выбранной категорией из списка
 
Простите за нечеткую формулировку, попытаюсь объяснить подробнее

Макрос должен проставить "Название_Характеристики" "Измерение_Характеристики" "Значение_Характеристики" начиная со столбца "D" при выборе категории из выпадающего списка
В колонке "А" листа "Товары" выбираем категорию из выпадающего списка (он ссылается на лист "category id")
Например мы выбрали категорию "Светодиодный неон".

Макрос  берет category id из той же строки, где стоит "светодиодный неон" (в данном случае 2)
Далее на листе "Atribut ID-category_id" расположены в 1 строке- category_id, а под ним соответствующие данной категории  Atribut ID.
В строке 1 макрос ищет это значение (в данном случае 2). Под ним находятся Atribut ID (14,149,13,155...)

Макрос берет значение Atribut ID из листа "Atribut ID" (14-Цвет свечения, 149- Температура свечения и т.д.) и вставляет "Название_характеристики" и "Измерение_характеристики" на лист "Товары"  столбцы "Название_характеристики" и "Измерение_характеристики" (в данном случае "D" "E") столбец "F" оставляет пустым для ручного заполнения
И повторяет этот цикл для каждого Atribut ID
Изменено: vikttur - 09.06.2021 17:50:53
 
Максим Николаевич, не нужно цитировать ВЕСЬ пост. ЦИТАТА должна вырезать ФРАГМЕНТ текста, непосредственно на который вы хотите ответить
Для простого обращения есть кнопка "Имя"
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) [►Кошелёк и контакты◄]
 
Не уверен, смог ли я все объяснить. Если нет, готов ответить на уточняющие вопросы
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Columns(1)) Is Nothing Then
            If Target.Row > 1 Then
                Range(Cells(Target.Row, 4), Cells(Target.Row, Columns.Count)).ClearContents
                If Target.Value <> "" Then
                    FillHar Target
                End If
            End If
        End If
    End If
End Sub

Sub FillHar(ByVal Target As Range)
    Dim y As Long
    On Error Resume Next
    y = WorksheetFunction.Match(Target.Value, Sheets("category_id").Columns(2), 0)
    On Error GoTo 0
    If y > 0 Then
        Dim x As Long
        On Error Resume Next
        x = WorksheetFunction.Match(Sheets("category_id").Cells(y, 1).Value, Sheets("Atribut ID-category_id").Rows(1), 0)
        If x = 0 Then x = WorksheetFunction.Match(CStr(Sheets("category_id").Cells(y, 1).Value), Sheets("Atribut ID-category_id").Rows(1), 0)
        If x = 0 Then x = WorksheetFunction.Match(CInt(Sheets("category_id").Cells(y, 1).Value), Sheets("Atribut ID-category_id").Rows(1), 0)
        On Error GoTo 0
        If x > 0 Then
            With Sheets("Atribut ID-category_id")
                y = .Cells(1, x).End(xlDown).Row
                Dim brr As Variant
                brr = .Range(.Cells(1, x), .Cells(y, x))
            End With
            If y > 1 And y < Columns.Count / 3 - 4 Then
                With Sheets("Atribut ID")
                    x = .Cells(.Rows.Count, 1).End(xlUp).Row
                    Dim xrr As Variant
                    xrr = .Range(.Cells(1, 1), .Cells(x, 3))
                End With
                
            
                Dim arr As Variant
                ReDim arr(1 To 1, 1 To 3 * y)
                For y = 2 To UBound(brr, 1)
                    x = 0
                    On Error Resume Next
                    x = WorksheetFunction.Match(brr(y, 1), Sheets("Atribut ID").Columns(2), 0)
                    If x = 0 Then x = WorksheetFunction.Match(CStr(brr(y, 1)), Sheets("Atribut ID").Columns(2), 0)
                    If x = 0 Then x = WorksheetFunction.Match(CInt(brr(y, 1)), Sheets("Atribut ID").Columns(2), 0)
                    On Error GoTo 0
                    If x > 0 Then
                        arr(1, 3 * (y - 2) + 1) = xrr(x, 1)
                        arr(1, 3 * (y - 2) + 2) = xrr(x, 3)
                    End If
                Next
                Target.Cells(1, 4).Resize(1, UBound(arr, 2)) = arr
            End If
        End If
    End If
End Sub
 
МатросНаЗебре, пожалуйста, Вы не могли бы макрос вставить в мой файл "1. Все х-ки.xlsx" у меня он почему-то не отображается в списке макросов, уже долго мучаюсь, не могу понять причину, почему не работает
Изменено: Максим Николаевич - 09.06.2021 16:43:30
 
Это в стандартный модуль.
Код
Option Explicit

Sub CreateOpenCard()
    Dim shT As Worksheet
    On Error Resume Next
    Set shT = Sheets("Товары ")
    On Error GoTo 0
    If shT Is Nothing Then Exit Sub
    With shT
        Dim rOut As Range
        Set rOut = Workbooks.Add(1).Sheets(1).Cells(2, 1)
        
        Dim orr As Variant
        Dim c As Range
        For Each c In .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
            FillHar c, orr, False
            If Not IsEmpty(orr) Then
                rOut.Resize(UBound(orr, 1), UBound(orr, 2)) = orr
                Set rOut = rOut.Offset(UBound(orr, 1))
            End If
        Next
    End With
    
    rOut.Parent.Parent.Saved = True
End Sub

Sub FillHar(ByVal Target As Range, orr As Variant, fillTov As Boolean)
    Dim wb As Workbook
    Set wb = Target.Parent.Parent
    
    Dim y As Long
    On Error Resume Next
    y = WorksheetFunction.Match(Target.Value, wb.Sheets("category_id").Columns(2), 0)
    On Error GoTo 0
    If y > 0 Then
        Dim x As Long
        On Error Resume Next
        x = WorksheetFunction.Match(wb.Sheets("category_id").Cells(y, 1).Value, wb.Sheets("Atribut ID-category_id").Rows(1), 0)
        If x = 0 Then x = WorksheetFunction.Match(CStr(wb.Sheets("category_id").Cells(y, 1).Value), wb.Sheets("Atribut ID-category_id").Rows(1), 0)
        If x = 0 Then x = WorksheetFunction.Match(CInt(wb.Sheets("category_id").Cells(y, 1).Value), wb.Sheets("Atribut ID-category_id").Rows(1), 0)
        On Error GoTo 0
        If x > 0 Then
            With wb.Sheets("Atribut ID-category_id")
                y = .Cells(1, x).End(xlDown).Row
                Dim brr As Variant
                brr = .Range(.Cells(1, x), .Cells(y, x))
                
                If y > 1 Then
                    ReDim orr(1 To y - 1, 1 To 5)
                Else
                    If Not IsEmpty(orr) Then Erase orr
                End If
            End With
            If y > 1 And y < Columns.Count / 3 - 4 Then
                With wb.Sheets("Atribut ID")
                    x = .Cells(.Rows.Count, 1).End(xlUp).Row
                    Dim xrr As Variant
                    xrr = .Range(.Cells(1, 1), .Cells(x, 3))
                End With
                
            
                Dim arr As Variant
                ReDim arr(1 To 1, 1 To 3 * y)
                For y = 2 To UBound(brr, 1)
                    x = 0
                    On Error Resume Next
                    x = WorksheetFunction.Match(brr(y, 1), wb.Sheets("Atribut ID").Columns(2), 0)
                    If x = 0 Then x = WorksheetFunction.Match(CStr(brr(y, 1)), wb.Sheets("Atribut ID").Columns(2), 0)
                    If x = 0 Then x = WorksheetFunction.Match(CInt(brr(y, 1)), wb.Sheets("Atribut ID").Columns(2), 0)
                    On Error GoTo 0
                    If x > 0 Then
                        arr(1, 3 * (y - 2) + 1) = xrr(x, 1)
                        arr(1, 3 * (y - 2) + 2) = xrr(x, 3)
                    End If
                    
                    orr(y - 1, 1) = Target.Cells(1, 2).Value
                    orr(y - 1, 4) = brr(y, 1)
                    orr(y - 1, 5) = Target.Cells(1, 3 * (y - 2) + 6).Value
                Next
                If fillTov Then Target.Cells(1, 4).Resize(1, UBound(arr, 2)) = arr
            End If
        End If
    End If
End Sub

Это в модуль листа. Правый клик на ярлыке листа - Исходный текст.
Код
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Columns(1)) Is Nothing Then
            If Target.Row > 1 Then
                Range(Cells(Target.Row, 4), Cells(Target.Row, Columns.Count)).ClearContents
                If Target.Value <> "" Then
                    Dim orr As Variant
                    FillHar Target, orr, True
                End If
            End If
        End If
    End If
End Sub

Файл с макросом пока выложить не могу из-за сетевых настроек.
 
Простите, а может кто-то еще может вставить макрос в файл, пожалуйста... ну не работает он у меня
 
Максим Николаевич,  :D  покажите Ваш файл куда вы вставили.
Не бойтесь совершенства. Вам его не достичь.
 
На всякий случай. Заполнение на листе "Товары " происходит после редактирования ячейки в столбце А.

Цитата
Максим Николаевич написал:
на 1-м листе "Товары". В колонке А из выпадающего списка при выборе категории должна проставиться вся строка значений
 
Цитата
Я думаю, бесполезно спрашивать третий раз, откуда макрос должен взять данные
Я и второй раз не буду..
 
Александр Моторин, я же вроде расписал https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=141145&a...

вроде уже вставил все правильно, но при клике по ячейке в столбце "А" ничего не происходит. Помогите....
Изменено: vikttur - 10.06.2021 12:51:15
 
Цитата
МатросНаЗебре написал:
Это в стандартный модуль.
Цитата
МатросНаЗебре написал:
Это в модуль листа
Вроде все буковки русские.
 
Все сделал как описано в теме (кажется). 1-й макрос вставил сюда https://prnt.sc/151vd9q
2-й макрос сюда https://prnt.sc/151ulgo
а в итоге выдает это https://prnt.sc/151uu67

Подскажите, что я не так делаю, пожалуйста. Мне очень нужен уже сейчас этот файл для работы
Изменено: vikttur - 10.06.2021 12:52:26
 
Ээээээ.... ну ладно.
Цитата
МатросНаЗебре написал:
Это в стандартный модуль.
Страницы: 1
Читают тему (гостей: 1)
Наверх