Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Разбивка по строкам
 
#1
16.06.2021 15:18:41
Добрый день, столкнулся с проблемой разбивки по строкам, есть файл выгрузки поставщиков одежды, вот пример:


Название             Артикул               Цена             Старая цена               Картинки            Параметры                 Размер
 
      1                          2                        3                        4                                 5                          6                          S, M, L, XL


Нужно сделать что бы на каждый размер колонки дублировались. Вот как должно получиться:



Название             Артикул               Цена             Старая цена               Картинки            Параметры                 Размер
 
      1                          2                        3                        4                                 5                          6                               S

 
      1                          2                        3                        4                                 5                          6                               M


      1                          2                        3                        4                                 5                          6                               L

 
      1                          2                        3                        4                                 5                          6                              XL



В ручную не вариант, товаров свыше 60К
 
 
 
#2
16.06.2021 15:43:36
Код
Sub SplitSize()
    Dim sh1 As Worksheet
    Set sh1 = ActiveSheet
    
    Dim y As Long
    Dim arr As Variant
    With sh1
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, "G"))
    End With
    
    Dim sh2 As Worksheet
    Set sh2 = Workbooks.Add(1).Sheets(1)
    
    Dim brr As Variant
    Dim orr As Variant
    ReDim orr(1 To sh2.Rows.Count, 1 To UBound(arr, 2))
    
    Dim i As Byte
    Dim x As Byte
    Dim u As Long
    u = 2
    For y = 2 To UBound(arr, 1)
        If arr(y, 7) = "" Then
            ReDim brr(0 To 0)
        Else
            brr = Split(arr(y, 7), ",")
        End If
        For i = 0 To UBound(brr)
            For x = 1 To 6
                orr(u, x) = arr(y, x)
            Next
            orr(u, 7) = brr(i)
            u = u + 1
            If u > UBound(orr, 1) Then Exit For
        Next
        If u > UBound(orr, 1) Then Exit For
    Next
    Erase arr
    
    If u < UBound(orr, 1) Then
        ReDim arr(1 To u, 1 To UBound(orr, 2))
        For y = 2 To UBound(arr, 1)
        For x = 1 To UBound(arr, 2)
            arr(y, x) = orr(y, x)
        Next
        Next
        orr = arr
        Erase arr
    End If
    
    sh2.Cells(1, 1).Resize(UBound(orr, 1), UBound(orr, 2)) = orr
    sh2.Parent.Saved = True
End Sub
Изменено: МатросНаЗебре - 16.06.2021 15:50:30
 
 
 
#3
17.06.2021 12:12:15
Вариант, для размещения данных как на изображении:

Код
Option Explicit

Sub razbivka_po_strokam()
    Const dlm = ","
    
    Dim i&, ii&, j&, jj&, k&, n&
    Dim arr, splt, tbl
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    With Range("A1").CurrentRegion
        arr = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
    End With
    
    ii = UBound(arr, 1): jj = UBound(arr, 2)
    For i = 1 To ii
        j = j + UBound(Split(arr(i, 7), dlm, -1, 0)) + 1
    Next
    ReDim tbl(1 To j, 1 To jj)
    jj = jj - 1
    
    For i = 1 To ii
        splt = Split(arr(i, 7), dlm, -1, 0)
        For n = 0 To UBound(splt)
            k = k + 1
            For j = 1 To jj
                tbl(k, j) = arr(i, j)
            Next
            tbl(k, j) = splt(n)
        Next
    Next
    
    arr = Empty: splt = Empty
    Range("A2").Resize(k, jj + 1).Value = tbl
    tbl = Empty
    
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
 
 
Страницы: 1
Наверх