Скопировать определенный диапазон из нескольких листов на один лист в виде скользящего отчета

Question

Это мой первый раз, поэтому извините заранее.

У меня есть файл с несколькими листами, мне нужно скопировать с A14 на I14, а затем сделать

Range(Selection, Selection.End(xlDown)).Select

Для того, чтобызахватить все данные от исходного диапазона до нижнего, все листы имеют разное количество строк, поэтому мне нужно это сделать.

После выбора данных мне нужно скопировать и вставить в другую вкладку под названием «Отчет»", и мне нужно сделать это для каждого листа в рабочей книге.

Каждый раз, когда лист вставляется во вкладку" Отчет ", следующий лист должен переходить в следующую строку авиалибра на вкладке" Отчет "в другихСлова не могу вставить над последней информацией.Это скользящий отчет.

Answer 1

Take this as base and adjust to your requirement. This program is Untested and may require adjustment for Header Rows. I have commented out Header Rows in program keeping in view you want to start from `Row1`

Sub CopyToReport()
    Dim wrk As Workbook         'Workbook object - Always good to work with object variables
    Dim sht As Worksheet        'Object for handling worksheets in loop
    Dim trg As Worksheet        'Master Worksheet
    Dim rng As Range            'Range object
    Dim colCount As Integer     'Column count in tables in the worksheets

    'Speed things up
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

    'Working in active workbook
        Set wrk = ActiveWorkbook

    'Create/Reset the Report sheet
        If Evaluate("ISREF(Report!A1)") Then
            wrk.Sheets("Report").Move After:=Worksheets(Worksheets.Count)
            wrk.Sheets("Report").Cells.Clear
        Else
            wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count)).Name = "Report"
        End If

        Set trg = wrk.Sheets("Report")

        'Get column headers from the first worksheet
            'Column count first
            Set sht = wrk.Worksheets(1)
           ' colCount = sht.Cells(1, Columns.Count).End(xlToLeft).Column
             colCount =9
            'Now retrieve headers, no copy&paste needed
            'With trg.Cells(1, 1).Resize(1, colCount)
             '   .Value = sht.Cells(1, 1).Resize(1, colCount).Value
              '  'Set font as bold
               ' .Font.Bold = True
            'End With

        'We can start loop
        For Each sht In wrk.Worksheets
            'Execute on every sheet except the Master
            If sht.Name <> "Master" Then
                'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
                'Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(Rows.Count, colCount).End(xlUp))
                Set rng = sht.Range("A1:I14")
                'Put data into the Master worksheet
                trg.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
            End If
        Next sht

        'Fit the columns in Master worksheet
            trg.Columns.AutoFit

        'Screen updating should be activated
            Application.ScreenUpdating = True
    End Sub

Answer 2

Не понимаю проблему, но некоторые советы:

Найдите последнюю использованную строку, используя:

Dim LastRow As Long
Dim ws as Worksheet
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

Примечание: ищется столбец 1 (A).

Переберите все листы, используя:

Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
         'Your code goes here
    next ws