Страницы: 1
RSS
VBA макрос вставляет строку на основе данных из ячейки
 
Привет друзья, есть умная таблица (прайс-лист) примерно 500 строк и 20 колонок, вся она создана на основе данных других с др  листов. Обновляю я ее протягиванием и выглядит примерно так:

SKUID NAME QTY тд
12323 HJWW001,HJWW003 text 5 text
Задача в столбце B(2) она же ID при нахождении запятой, дублировать
строку соответственно количеству запятых, в колонке SKU менять на SKU + ID а в колонке B оставлять только один ID вот так:

SKU ID NAME QTY тд
 12323-HJWW001 HJWW001 text 5 text
 12323-HJWW003 HJWW003 text 5 text
Я нашел код, который работает, но у него есть минусы, поэтому прошу помощи в доработке
1. самое главное он очень сильно тормозит
2. если в колонке ID если ошибка (#N/A и тд ) то он не может обработать и вылетает

Код
Sub ExpandRows()
  Dim a As Variant, vals As Variant
  Dim i As Long, rws As Long
  
  Application.ScreenUpdating = False
  With Range("A3:B" & Range("A" & Rows.Count).End(xlUp).Row)
    a = .Columns(2).Value2
    For i = UBound(a) To 1 Step -1
     ' vals = Split(Mid(a(i, 1), 2, Len(a(i, 1)) - 2), ",")
       vals = Split(a(i, 1), ",")
      rws = UBound(vals) + 1
      If rws > 1 Then
        .Rows(i + 1).Resize(rws - 1).Insert
        .Rows(i).Copy Destination:=.Rows(i).Resize(rws)
      End If
   .Cells(i, 2).Resize(rws).Value = Application.Transpose(vals)
   ' .Cells(i, 13).Resize(rws).Value = Destination.Resize(UBound(vals, 2) + 1, UBound(vals, 1) + 1) = Application.Transpose(vals)
   
     
    Next i
  End With
  Application.ScreenUpdating = True
  End Sub
СПАСИБО
 
Alexander Kruglov, приложите файл примера с ожидаемым результатом.
Вредить легко, помогать трудно.
 
Заметил еще одну проблему в макросе, добавляется только второй столбец, то есть все остальные данные остаются. Вот файл пример.
лист "фрагмент для теста" часть прайс-листа для тестирования протягивать можно со второй строки
лист "как должно быть" вручную создан для примера какой результат хотелось бы получить
 
Power Query:
Код
let
    Источник = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Измененный тип" = Table.TransformColumnTypes(Источник,{{"SKU", type text}, {"#(tab)ID", type text}, {"NAME", type text}, {"QTY", type number}, {"PRICE", type number}}),
    #"Разделить столбец по разделителю" = Table.ExpandListColumn(Table.TransformColumns(#"Измененный тип", {{"#(tab)ID", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "#(tab)ID")
in
    #"Разделить столбец по разделителю"
Изменено: Msi2102 - 04.07.2022 10:37:05
 
Alexander Kruglov, добрый день!
Вариант с листом Управление.
Вводите критерии отбора (см пример заполнения - 3 строку) или оставляете пустыми ячейки В2 и С2 для выбора всех значений.
Жмете кнопку и результат выгружается на лист Result
Код
Private Sub CommandButton1_Click()
Dim myConnect As String, mySQL As String, myRecord As Object, QT As QueryTable
Dim wshTarget As Worksheet, conn
With ActiveWorkbook
        myConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & .FullName & ";" & _
           "Extended Properties=""Excel 12.0;HDR=YES"""
    Set myRecord = CreateObject("ADODB.Recordset")
With Worksheets("Управление")
    If .Cells(2, 2) = "" And .Cells(2, 3) = "" Then
        mySQL = "SELECT * FROM [Исходные$]"
    ElseIf .Cells(2, 2) = "" Or .Cells(2, 3) = "" Then
        MsgBox "Заполните все критерии отбора!!!!", vbCritical: Set myRecord = Nothing: Exit Sub
    Else
        mySQL = "SELECT SKU, ID, NAME, QTY, PRICE FROM [Исходные$] WHERE " & .Cells(2, 2) & "='" & .Cells(2, 3) & "'"
    End If
On Error GoTo Errorh
    myRecord.Open mySQL, myConnect
End With
    Set wshTarget = .Worksheets("Result")
With wshTarget
    .Cells.Clear
    Set QT = .QueryTables.Add(myRecord, .Range("A1"))
    QT.Refresh
End With
    Set QT = Nothing
    myRecord.Close
    Set myRecord = Nothing
For Each conn In .Connections
    conn.Delete
Next conn
For Each conn In Worksheets("Result").QueryTables
    conn.Delete
Next conn
End With
Exit Sub
Errorh:
    MsgBox "Проверьте корректность написания условия отбора!!!", vbCritical
    Set myRecord = Nothing
End Sub
 
Спасибо за потраченное время, видимо я не смог правильно описать задачу. У меня задача найти все строки в колонке ID где есть "," и от дублировать их а в колонку SKU добавить в конце текста ID.
 
Alexander Kruglov,

Код
Sub Разбить_ID()
    Dim LO As ListObject, i As Long, n As Long, SKU As String, ID As String

    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Set LO = ActiveSheet.ListObjects(1)
    With LO
        For i = .DataBodyRange.Rows.Count + 1 To 1 Step -1
            If InStr(1, .Range.Cells(i, 2), ",", vbTextCompare) > 0 Then
                SKU = .Range.Cells(i, 1)
                ID = .Range.Cells(i, 2)
                .Range.Cells(i, 1) = SKU & "-" & Split(ID, ",")(0) 'SKU
                .Range.Cells(i, 2) = Split(ID, ",")(0) 'ID
                For n = 1 To UBound(Split(ID, ","))
                    .ListRows.Add (i + n - 1)
                    .ListRows(i - 1).Range.Copy .ListRows(i + n - 1).Range
                    .Range.Cells(i + n, 1) = SKU & "-" & Split(ID, ",")(n) 'SKU
                    .Range.Cells(i + n, 2) = Split(ID, ",")(n) 'ID
                Next n
            End If
        Next i
    End With
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Конец", vbInformation, ""
End Sub
Изменено: New - 07.07.2022 08:25:57
 
Спасибо огромное это то что нужно, а можно ее как то ускорить?
 
Alexander Kruglov, я поправил выше код, скопируйте его заново. Это максимум, что можно сделать. А сколько времени он у вас выполняется?
Изменено: New - 07.07.2022 08:24:26
 
Цитата
написал:
UBound(
Спасибо, я тоже сейчас пытаюсь оптимизировать, перевожу формулы в значения, умную таблицу в обычную, пробую отфильтровать таблицу только там где нужна обработка, а потом обработанное скопировать обратно, но пока не очень выходит. Примерно 30 сек выходит, интересно почему так медленно, может другой разделитель указать или как-то обойти его можно. Я так понял если отфильтровать он все равно всю таблицу будет просматривать
 
ну, фильтруй - не фильтруй... Макрос всё равно идёт от самой нижней строки к 1-й и ищет запятую во втором столбце. Почему так долго я не знаю, возможно у вас много Условного форматирования где-то на листах в вашем файле. Условное форматирование - пересчитывается при любом изменении в любой ячейке на любом листе в файле и это подвешивает файл. Но наличие у вас условного форматирование - это лишь моё предположение
Изменено: New - 07.07.2022 20:15:54
 
ok спасибо
Страницы: 1
Читают тему (гостей: 1)
Наверх