Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос копирования вставки данных в транспонированном виде
 
#1
02.03.2017 12:33:06
Добрый день, уважаемые специалисты.
К сожалению, с программированием не дружу, поэтому прошу Вашей помощи.
Для загрузки товаров в магазин из эксель нужно исходные данные привести к другому формату.
Первый столбец с ID всех товаров.
Столбцы 2-5 первой строки - названия аттрибутов.
Столбцы 2-5 и строки со 2-й - это сами аттрибуты товаров, у которых в первом столбце ID.

Нужно в столбец, например 7,  вставить ИД товара в строки, количество которых равно количеству названий аттрибутов.
В столбец 8 вставить названия аттрибутов транспонированно, а в столбец 9 - значения аттрибутов.
И потом так же обработать следующие строки, пока ИД товаров не закончатся.

Попытался сделать макрос, может как-то удасться автоматизировать - не удалось, не знаю как все это правильно написать.
Код
Sub example()
' example Макрос
    Range("B1:E1").Select
    Selection.Copy
    Range("H1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("B2:E2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("I1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G1").Select
    ActiveSheet.Paste
    Range("G1:G4").Select
    Application.CutCopyMode = False
    Selection.FillDown
    Range("B1:E1").Select
    Selection.Copy
    Range("H5").Select
    ActiveSheet.Paste
    Range("H5").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("B3:E3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("I5").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("A3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G5").Select
    ActiveSheet.Paste
    Range("G5:G8").Select
    Application.CutCopyMode = False
    Selection.FillDown
    Range("J9").Select
    ActiveCell.FormulaR1C1 = ""
    Range("G9").Select
End Sub

Очень прошу Вашей помощи, ребят, руками тысячи позиций переделать нереально просто(
 
 
 
#2
02.03.2017 12:46:13
Код
Sub ReTbl()
Dim arrTemp()
Dim arrVAl
Dim I&, J&, N&
On Error Resume Next
arrVAl = Range("A1:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
For I = 2 To UBound(arrVAl, 1)
    For J = 2 To UBound(arrVAl, 2)
        If arrVAl(I, J) <> Empty Then
            ReDim Preserve arrTemp(2, N)
            arrTemp(0, N) = arrVAl(I, 1)
            arrTemp(1, N) = arrVAl(1, J)
            arrTemp(2, N) = arrVAl(I, J)
            N = N + 1
        Else
            Exit For
        End If
    Next
Next
Range("K1").Resize(UBound(arrTemp, 2) + 1, 3) = Application.Transpose(arrTemp)
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
02.03.2017 12:53:00
Добрый день.
Если операция разовая, то, м.б., формул будет достаточно?
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
 
 
#4
02.03.2017 12:57:17
Sanja, матерь Божья, работает!!! Спасибо Вам огромное, в 15 минут решили эту тяжелую для меня проблему!! Дай Бог здоровья, +1000 к карме!)
 
 
 
#5
02.03.2017 12:59:20
Михаил Лебедев, к сожалению, не разовая( Спасибо за ответ!
 
 
 
#6
02.03.2017 13:07:13
Просто дежавю какое-то...
Нашёл :)
http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=88712&TITLE_SEO=88712-makros-dlya-preobrazovaniya-tablitsy&buf_fid=1
 
 
 
#7
02.03.2017 13:09:06
Цитата
gege написал: в 15 минут решили эту тяжелую для меня проблему!
Цитата
Hugo написал: Нашёл
:D
Согласие есть продукт при полном непротивлении сторон
 
 
 
Страницы: 1
Наверх