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

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

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

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

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

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

Сообщений: 7

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

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

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

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

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

Ответить

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

Sub Combine()'Update by ExtendofficeDim i As IntegerDim xTCount As VariantDim xWs As WorksheetOn Error Resume NextLInput:xTCount = Application.InputBox("Тhe number of title rows"; ""; "1")If ТypeЧame(xTCount) = "Boolean" Then Exit SubIf Not IsЧumeric(xTCount) ThenMsgBox "Only can enter number"; ; "Kutools for Excel"GoTo LInputEnd IfSet xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))xWs.Name = "Свод"Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")For i = 2 To Worksheets.CountWorksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount); 0).Copy _Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1; 1)NextEnd Sub

[/vba]

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

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

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

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

Сообщений: 431

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

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

MSO LTSC 2021 EN

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

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

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

Ответить

Vika101928

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

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

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

Сообщений: 7

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

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

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

Ответить

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

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

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

Сообщений: 431

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

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

MSO LTSC 2021 EN

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

писал(а)):

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

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

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