Извлечение определенных значений ячейки местоположения из нескольких листов в Excel вместе с именем листа

Question

Я столкнулся с проблемой во время работы.

В моем файле Excel содержится более ста таблиц, и я хотел бы извлечь значения из определенного местоположения (I25: K25, I50: K50, I95: K95) вместе с именем рабочей таблицы на каждой странице.

Я хотел бы вставить эти извлеченные значения в новый лист.

Кто-нибудь знает, есть ли какая-нибудь формула Excel или макрос Excel, которые я мог бы использовать для достижения цели?

Answer 1

Этот кодовый цикл выполняет все листы, кроме листа с именем «Результаты», имени кодового листа в столбце A и значений диапазона в столбцах B: D.

Option Explicit

Sub test()

    Dim ws As Worksheet, wsResults As Worksheet
    Dim Lastrow As Long

    With ThisWorkbook

        Set wsResults = .Worksheets("Results")

        For Each ws In .Worksheets
            If ws.Name <> "Results" Then
                Lastrow = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row
                wsResults.Range("A" & Lastrow + 1 & ":A" & Lastrow + 3).Value = ws.Name
                ws.Range("I25:K25").Copy wsResults.Range("B" & Lastrow + 1)
                ws.Range("I50:K50").Copy wsResults.Range("B" & Lastrow + 2)
                ws.Range("I95:K95").Copy wsResults.Range("B" & Lastrow + 3)
            End If
        Next ws

    End With

End Sub

Answer 2

Относится к новой основной рабочей таблице

• Загрузка рабочей книги (Dropbox)
• Настройте значения в разделе констант (Const) в соответствии с вашими потребностями.
• Код будет влиять только на рабочую книгу, содержащую его.
• Код удалит возможный существующий рабочий лист с именем cTarget, но будет считывать только из всех других рабочих листов.Затем он создаст лист с именем cTarget и запишет в него считанные данные.
• Чтобы запустить код, перейдите на вкладку Developer, нажмите Macros и нажмите RangesToNewMasterWorksheet. * 1020.*

Sub RangesToNewMasterWorksheet()

    ' List of Source Row Range Addresses
    Const cRowRanges As String = "I25:K25, I50:K50, I95:K95"
    Const cTarget As String = "Result"  ' Target Worksheet Name
    Const cHead1 As String = "ID"       ' 1st Column Header
    Const cHead2 As String = "Name"     ' 2nd Column Header
    Const cHead As Long = 2             ' Number of First Header Columns
    Const cRange As String = "Rng"      ' Range (Area) String
    Const cColumn As String = "C"       ' Column String
    Const cFirstCell As String = "A1"   ' Target First Cell Range Address

    Dim wb As Workbook    ' Source/Target Workbook
    Dim ws As Worksheet   ' Current Source/Target Worksheet
    Dim rng As Range      ' Current Source/Target Range
    Dim vntT As Variant   ' Target Array
    Dim vntA As Variant   ' Areas Array
    Dim vntR As Variant   ' Range Array
    Dim NoA As Long       ' Number of Areas
    Dim NocA As Long      ' Number of Area Columns (in Target Array)

    Dim i As Long   ' Area Counter
    Dim j As Long   ' Area Column Counter
    Dim k As Long   ' Target Array Row Counter
    Dim m As Long   ' Target Array Column Counter

    ' Speed Up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    ' Create a reference to ThisWorkbook i.e. the workbook containing this code.
    Set wb = ThisWorkbook

    ' Task: Delete a possibly existing instance of Target Worksheet.

    Application.DisplayAlerts = False
        On Error Resume Next
            wb.Worksheets(cTarget).Delete
        On Error GoTo 0
    Application.DisplayAlerts = True

    ' Handle unexpected error.
    On Error GoTo UnExpected

    ' Task: Calculate size of Target Array.

    ' Create a reference to the 1st worksheet. (Note: Not sheet.)
    For Each ws In wb.Worksheets
        Exit For
    Next
    ' Create a reference to the Source Row Range (in 1st worksheet.
    Set rng = ws.Range(cRowRanges)
    With rng
        NoA = .Areas.Count
        ReDim vntA(1 To NoA)
        ' Calculate Number of Area Columns (NocA).
        For i = 1 To NoA
            With .Areas(i)
                ' Write number of columns of current Area (i) to Areas Array.
                vntA(i) = .Columns.Count
                NocA = NocA + vntA(i)
            End With
        Next
    End With

    ' Resize Target Array.
    '   Rows:     Number of worksheets + 1 for headers.
    '   Columns:  Number of First Header Columns + Number of Area Columns.
    ReDim vntT(1 To wb.Worksheets.Count + 1, 1 To cHead + NocA)

    ' Task: Write 'Head' (headers) to Target Array.

    vntT(1, 1) = cHead1
    vntT(1, 2) = cHead2
    k = cHead
    For i = 1 To NoA
        For j = 1 To vntA(i)
            k = k + 1
            vntT(1, k) = cRange & i & cColumn & j
        Next
    Next

    ' Task Write 'Body' (all except headers) to Target Array.

    k = 1
    For Each ws In wb.Worksheets
        k = k + 1
        vntT(k, 1) = k - 1
        vntT(k, 2) = ws.Name
        Set rng = ws.Range(cRowRanges)
        m = cHead
        For i = 1 To NoA
            vntR = rng.Areas(i)
            For j = 1 To vntA(i)
                m = m + 1
                vntT(k, m) = vntR(1, j)
            Next
        Next
    Next

    ' Task: Copy Target Array to Target Worksheet.

    ' Add new worksheet to first tab (1).
    Set ws = wb.Sheets.Add(Before:=wb.Sheets(1))
    ws.Name = cTarget
    ' Calculate Target Range i.e. resize First Cell Range by size of
    ' Target Array.
    Set rng = ws.Range(cFirstCell).Resize(UBound(vntT), UBound(vntT, 2))
    rng = vntT

    ' Task: Apply Formatting.

    ' Apply formatting to Target Range.
    With rng
        .Columns.AutoFit
        ' Apply formatting to Head (first row).
        With .Resize(1)
            .Interior.ColorIndex = 49
            With .Font
                .ColorIndex = 2
                .Bold = True
            End With
            .BorderAround xlContinuous, xlThin
            .Borders(xlInsideVertical).LineStyle = xlContinuous
        End With
        ' Apply formatting to Body (all except the first row).
        With .Resize(rng.Rows.Count - 1).Offset(1)
            .Interior.ColorIndex = xlColorIndexNone
            With .Font
                .ColorIndex = xlColorIndexAutomatic
                .Bold = False
            End With
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
        End With
    End With

    MsgBox "The program finished successfully.", vbInformation, "Success"

ProcedureExit:

    ' Speed Down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

UnExpected:
    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

Answer 3

Я не очень хорошо разбираюсь в формулах, но с VBA это вполне возможно.

Изучите циклы For Each..Next, которые, я думаю, вам следует использовать для просмотра всех листов.

Далее свойство .Name извлечет для вас имя листа.Вы можете сохранить его в переменной и заполнить ячейку с помощью.

Получение значений из одной ячейки в другую так же просто, как

.Sheets(1).Range("A1:B1").Value = .Sheets(2).Range("A1:B1").Value

Обратите внимание, что SO не является бесплатной службой написания кода,так что я не буду так далеко, как писать всю процедуру для вас.Если у вас есть какой-то код, но вы столкнулись с проблемами, возвращайтесь к нам.

Полезные ссылки:

циклический просмотр листов

Копирование значений ячеек

Объекты рабочей книги и листа