Макрос - копирование данных с нескольких таблиц на другой лист с заголовком

Пользователь

Сообщений: 26 Регистрация: 12.02.2017

03.10.2018 07:29:01

Добрый день!
Подскажите пожалуйста, у меня перемещаются данные как надо, 2 таблицы на одном листе перемещаются на другой лист друг за дружкой в столбе А, как мне сделать, чтобы рядом с каждой позицией в столбце B был заголовок таблицы в которой она находилась?

Прикрепленные файлы

tables.xls (46 КБ)

Изменено: balagancha - 03.10.2018 07:29:53

Nordheim

Пользователь

Сообщений: 3154 Регистрация: 18.04.2017

03.10.2018 09:23:04

Код

Sub test()
'   --------------------------------------------
    Dim lColumn%, i%, txt$, lRow&, j%, arr()
    Dim sht1 As Worksheet, sht2 As Worksheet
'   --------------------------------------------
    Set sht1 = ThisWorkbook.Worksheets("Лист1")
    Set sht2 = ThisWorkbook.Worksheets("Лист2")
    With sht1
        lColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For j = 1 To lColumn
            arr = .Range(.Cells(2, j), .Cells(1, j).End(xlDown)).Value
            lRow = sht2.Range("a" & sht2.Rows.Count).End(xlUp).Row + 1
            If lRow = 2 Then lRow = 1
            txt = .Cells(1, j).Value
            sht2.Range("a" & lRow).Resize(UBound(arr), 1).Value = arr
            sht2.Range("b" & lRow).Resize(UBound(arr), 1).Value = txt
        Next j
    End With
End Sub

"Все гениальное просто, а все простое гениально!!!"

balagancha Пользователь Сообщений: 26 Регистрация: 12.02.2017	#3 03.10.2018 10:21:57 Nordheim, супер, благодарю Вас от души. Всё работает.