Перенос данных из одного листа одной таблицы в создаваемые листы другой таблицы

@Dimitar · Регистрация: 17.05.2016

Author24 — интернет-сервис помощи студентам

Доброго времени суток! Подскажите пожалуйста как написать макрос в Excel для переноса данных из одного листа одной таблицы в создаваемые листы другой таблицы. Условия такие: есть таблица (Test), имеющая один лист (Лист1) с данными в трех столбцах, необходимо перенести информацию из ячеек столбцов "В" и "С" в другую таблицу (Nado), таким образом что ячейки первого столбца "А" первой таблицы (Test) должны стать названиями листов второй таблицы (Nado), при совпадении значений ячеек первого столбца "А" новая страница не должна создаваться, строки переносятся только на тот лист, который имеет название первой ячейки строки.
То есть нужен такой механизм:
1) копируем в буфер значение первой ячейки А1 таблицы Test, открываем таблицу Nado, создаем лист с именем из буфера (значение ячейки А1 таблицы Test);
2) копируем значения первой строчки ячеек "В1" и "С1" таблицы Test, соответственно, в ячейки "А1" "В1" первого листа (название="А1" таблицы Test) таблицы Nado;
3) далее сравниваем значение ячейки "А1" таблицы Test со значением ячейки "В1" таблицы Test, если "равно", то продолжаем записывать на тот же лист (название="А1" таблицы Test) таблицы Nado (В2 и С2 соответственно в А2 и В2), если "не равно", то создаем новый лист в таблице Nado c таким названием и копируем ячейки как описано выше (В2 и С2 таблицы Test соответственно в А1 и В1 нового листа таблицы Nado);
4) продолжаем до тех пор пока не кончатся данные.

Спасибо за Ваше потраченное время и силы!

@KoGG · 28.06.2016, 17:22

Visual Basic

Sub Perenos_v_Nado()
    Dim A, Sh, i%, LastRow&
    A = Workbooks("test.xlsx").Worksheets(1).[A1].CurrentRegion
    For Each Sh In Workbooks("nado.xlsx").Worksheets
        Sh.Cells.Clear
    Next Sh
    For i = 1 To UBound(A)
        A(i, 1) = format$(A(i, 1))
        With Workbooks("nado.xlsx")
            If Not SheetExists(A(i, 1), Workbooks("nado.xlsx")) Then
               With .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)): .Name = A(i, 1): End With
            End If
            With .Worksheets(A(i, 1))
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                If IsEmpty(.[A1]) Then LastRow = 1
                .Cells(LastRow, 1) = A(i, 2)
                .Cells(LastRow, 2) = A(i, 3)
            End With
        End With
    Next i
End Sub
Function SheetExists(SheetName, Optional wb As Workbook) As Boolean
    If wb Is Nothing Then Set wb = ActiveWorkbook
    On Local Error Resume Next: SheetExists = wb.Worksheets(SheetName).Name = SheetName: Err.Clear
End Function

	28.06.2016, 17:22

Опции темы

Перенос данных из одного листа одной таблицы в создаваемые листы другой таблицы

Решение