Копировать на сводный лист только определенные листы

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

Копировать на сводный лист только определенные листы (Макросы/Sub)

Vika101928

Дата: Понедельник, 21.04.2025, 13:24 | Сообщение № 1

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

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

Сообщений: 5

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

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

Здравствуйте уважаемые форумчане!
Помогите, пожалуйста. Мне необходимо в файле Excel с листов 1, 2, 3 скопировать определенные столбцы (с 1 по 23) (на каждом из листов 1, 2 и 3, столбцы находятся в одинаковой последовательности) на лист СВОД.
Я нашла макрос, который просто копирует ВСЕ листы из книги на новый лист.
Как мне его подкорректировать, чтобы я могла копировать только конкретные листы и только конкретные столбцы? Еще я заметила, что макрос копирует на сводный лист полностью таблицу с заголовками. Мне копирование каждый раз заголовков не нужно. И таблицы с копируемых листов (1, 2, 3) – это умные таблицы. Пример исходного файла и желаемого результата во вложении. Пример макроса ниже. Заранее благодарю за ответ!
[vba]

Код

Sub Combine()
'Update by Extendoffice
Dim i As Integer
Dim xTCount As Variant
Dim xWs As Worksheet
On Error Resume Next
LInput:
xTCount = Application.InputBox("The number of title rows", "", "1")
If TypeName(xTCount) = "Boolean" Then Exit Sub
If Not IsNumeric(xTCount) Then
MsgBox "Only can enter number", , "Kutools for Excel"
GoTo LInput
End If
Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
xWs.Name = "Свод"
Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
For i = 2 To Worksheets.Count
Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)
Next
End Sub

[/vba]

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

Ответить

СообщениеЗдравствуйте уважаемые форумчане!
Помогите, пожалуйста. Мне необходимо в файле Excel с листов 1, 2, 3 скопировать определенные столбцы (с 1 по 23) (на каждом из листов 1, 2 и 3, столбцы находятся в одинаковой последовательности) на лист СВОД.
Я нашла макрос, который просто копирует ВСЕ листы из книги на новый лист.
Как мне его подкорректировать, чтобы я могла копировать только конкретные листы и только конкретные столбцы? Еще я заметила, что макрос копирует на сводный лист полностью таблицу с заголовками. Мне копирование каждый раз заголовков не нужно. И таблицы с копируемых листов (1, 2, 3) – это умные таблицы. Пример исходного файла и желаемого результата во вложении. Пример макроса ниже. Заранее благодарю за ответ!
[vba]

Код

[/vba]

Автор - Vika101928
Дата добавления - 21.04.2025 в 13:24

MikeVol

Дата: Вторник, 22.04.2025, 07:57 | Сообщение № 2

Группа: Проверенные

Ранг: Обитатель

Сообщений: 424

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

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

MSO LTSC 2021 EN

Vika101928, Доьрого времени суток. Как-то так:[vba]

Код

Option Explicit

Sub СводныеДанные_для_Vika101928()
    Dim wsSource    As Worksheet
    Dim arrData     As Variant
    Dim lastRowSrc  As Long
    Dim i           As Long

    With ThisWorkbook.Worksheets("свод")
        .Range("A2:W" & .Rows.Count).ClearContents
    End With

    Dim sheetNames  As Variant
    sheetNames = Array("1", "2", "3")

    Dim lastRowTgt  As Long
    lastRowTgt = 1

    For i = LBound(sheetNames) To UBound(sheetNames)
        Set wsSource = ThisWorkbook.Worksheets(sheetNames(i))
        lastRowSrc = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
        If lastRowSrc < 2 Then GoTo NextSheet
        arrData = wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(lastRowSrc, 23)).Value
        ThisWorkbook.Worksheets("свод").Range("A" & lastRowTgt).Resize(UBound(arrData), 23).Value = arrData
        lastRowTgt = lastRowTgt + UBound(arrData)

NextSheet:
    Next i

End Sub

[/vba]

Ученик.
Одесса - Украина

Ответить

Vika101928

Дата: Вторник, 22.04.2025, 08:07 | Сообщение № 3

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

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

Сообщений: 5

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

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

Добрый день. Спасибо Вам большое!
Подскажите, пожалуйста, как можно на копируемый лист добавить в самую первую строку заголовки столбцов? Мне нужно чтобы первый раз заголовок скопировался, а далее со второго третьего листа уже не копировался заголовок.

Ответить

MikeVol

Дата: Вторник, 22.04.2025, 08:21 | Сообщение № 4

Группа: Проверенные

Ранг: Обитатель

Сообщений: 424

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

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

MSO LTSC 2021 EN

Цитата Vika101928, 22.04.2025 в 08:07, в сообщении № 3 (

)

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

Код будет чуть отличаться:[vba]

Код

Option Explicit

Sub СводныеДанные_для_Vika101928_v2()
    Dim wsTarget    As Worksheet
    Dim wsSource    As Worksheet
    Dim arrData     As Variant
    Dim lastRowSrc  As Long
    Dim i           As Long

    With ThisWorkbook.Worksheets("СВОД")
        .Range("A1:W" & .Rows.Count).ClearContents
    End With

    Dim sheetNames  As Variant
    sheetNames = Array("1", "2", "3")

    Dim lastRowTgt  As Long
    lastRowTgt = 2

    For i = LBound(sheetNames) To UBound(sheetNames)
        Set wsSource = ThisWorkbook.Sheets(sheetNames(i))
        lastRowSrc = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
        If lastRowSrc < 2 Then GoTo NextSheet

        If i = 0 Then
            ThisWorkbook.Worksheets("СВОД").Range("A1:W1").Value = wsSource.Range("A1:W1").Value
        End If

        arrData = wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(lastRowSrc, 23)).Value
        ThisWorkbook.Worksheets("СВОД").Range("A" & lastRowTgt).Resize(UBound(arrData), 23).Value = arrData
        lastRowTgt = lastRowTgt + UBound(arrData)

NextSheet:
    Next i

End Sub

[/vba]
Только что заметил свою ошибку в первой версии кода. Строку:[vba]

Код

lastRowTgt = 1

[/vba]замените на:[vba]

Код

lastRowTgt = 2

[/vba]