Макрос конкретное копирование

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Макрос конкретное копирование (Макросы/Sub)

Galexey

Дата: Среда, 24.01.2018, 20:46 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 5

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Всем привет!

Очень нужна помощь спецов. До не давнего времени думал, что я хорошо разбираюсь в EXEL.
Мне нужно создать макрос для копирования конкретных ячеек в конкретные ячейки другой таблицы.
Исходный файл хоть и кривой, но нужные ячейки находятся в строгом порядке. Задача также усложняется тем, что исходная таблица бывает с разным количеством данных. Вложил файл. На первом листе исходная таблица, на втором требуемая форма.
В таблицах обозначил цветами что от куда и куда.
Очень надеюсь на вашу помощь.

К сообщению приложен файл: 4821943.xlsx (77.7 Kb)

Ответить

nilem

Дата: Среда, 24.01.2018, 21:26 | Сообщение № 2

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

Galexey, привет
попробуйте вот так
[vba]

Код

Sub ertert()
Dim x, y(), i&, k&
With Sheets("Лист1")
    x = .Range("A8:N" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
End With
ReDim y(1 To UBound(x), 1 To 6)

For i = 1 To UBound(x)
    If Len(x(i, 1)) Then
        k = k + 1
        y(k, 1) = x(i, 1)
        y(k, 2) = x(i, 2)
        y(k, 3) = x(i + 1, 2)
        y(k, 4) = x(i, 7)
        y(k, 5) = x(i, 9)
        y(k, 6) = x(i, 13)
    End If
Next i

With Sheets("Лист2")
    .Range("A2").CurrentRegion.Offset(1).ClearContents
    .Range("A4:F4").Resize(k).Value = y()
End With
End Sub

[/vba]

Яндекс.Деньги 4100159601573