Уважаемые профи ексель, помогите! Я отблагодарю. Файл используется для того, чтобы проставлять характеристики товарам для пром и опенкарт. Есть 2 подзадачи.
1. (см файл "1. Все х-ки.xlsx")
Есть 2 идентификатора ID категории товара и ID характеристики товара. Работа производится на 1-м листе "Товары". В колонке А из выпадающего списка при выборе категории должна проставиться вся строка значений
Название_Характеристики
Измерение_Характеристики
для данной группы товаров.
2. Конвертировать выделенные строки полученного результата в формат опенкарт с колонками как в файле "2. Х-ки опенкарт.xlsx" Заполнить только колонки выделенные желтым
Я отблагодарю за работу (кто возьмется, укажите в начале, сколько Вы хотите). Нахожусь в Украине, не сталкивался с оплатой в Россию, прошу подсказать , если знаете, как это сделать.
Название_Характеристики Измерение_Характеристики Значение_Характеристики вот эти 3 столбца нужно заполнить, повторяя столько раз, сколько есть характеристик во вкладке "Atribut ID-category_id"
На листе "товары": Категория выбирается из выпадающего списка. Код товара и наименование заполняется вручную, остальные столбцы должен заполнить скрипт в соответствии с выбранной категорией из списка
Максим Николаевич написал: Название_ХарактеристикиИзмерение_ХарактеристикиЗначение_Характеристикивот эти 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 м Его нет ни в одной книге кроме как на листе "Товары" нахожусь в Украине
МатросНаЗебре , простите, мой уровень знания ексель такой, что я так и не смог вставить тот макрос, чтобы он работал. Точнее макрос я вставил, но он не отображается в спис ке всех макросов Не можете ли вы прислать уже готовый файл с макросом, пожалуйста?
На листе "товары": Категория выбирается из выпадающего списка. Код товара и наименование заполняется вручную, остальные столбцы должен заполнить скрипт в соответствии с выбранной категорией из списка
Простите за нечеткую формулировку, попытаюсь объяснить подробнее
Макрос должен проставить "Название_Характеристики" "Измерение_Характеристики" "Значение_Характеристики" начиная со столбца "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
Максим Николаевич, не нужно цитировать ВЕСЬ пост. ЦИТАТА должна вырезать ФРАГМЕНТ текста, непосредственно на который вы хотите ответить Для простого обращения есть кнопка "Имя"
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
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" у меня он почему-то не отображается в списке макросов, уже долго мучаюсь, не могу понять причину, почему не работает
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
Файл с макросом пока выложить не могу из-за сетевых настроек.