将特定工作表中的数据提取到新工作簿

Question

I'm currently having problems trying to extract cell data and pasting them into a new workbook. To make things clearer here are the steps

1. Access a specific worksheet ("Report") in all open workbooks (except the one running the macro)

2. From the worksheet, extract certain cell data (no. of rows and columns are not fixed but they are identical throughout the open workbooks)

3. Create a new workbook and paste the data there (each workbook will be assigned one row in the sheet, and all data extracted will be on the same sheet)

I'm having problems with my last sub that extracts this cell data and pastes it into a new workbook, here's what I have so far:

Function Extract_Report_Final(wb As Workbook, book As workbook, counter as long)

Dim last_row, last_col As Long
Dim ws As Worksheet
Dim i, j, k As Integer
Dim data() As String

With wb.Sheets("Report") 'for each worksheet in each open workbook

    last_row = .Range("C" & .Rows.Count).End(xlUp).Row
    last_col = .Cells(last_row, .Columns.Count).End(xlToLeft).Column
    'to get the last row and column where the data required will be located
    'this is identical throughout the workbooks as is the name of the worksheet

    ReDim data(last_col - 1)
    'I decided to use an array to store the values as i don't know how else :(

    For k = 0 To (last_col - 2)
        Select Case k

            Case 0: data(k) = .Cells(1, 1).Value
            Case 1: data(k) = .Cells(last_row, 3).Value
            Case Else: data(k) = .Cells(last_row, k + 2).Value
        End Select
    Next k

    k = 0
    'A weak attempt at trying to copy.paste the values onto a new workbook
    'I also don't know how to reference a newly created workbook :(

    For i = 1 To last_col
    '"book" is the variable workbook which will house the extracted data
    .book.ws.Cells(counter, i) = data(k)
    k = k + 1
    Next i

End Function

Below is my main sub:

Sub Cycle_wb()

Dim ws As Worksheet
Dim wb As Workbook
Dim book As Workbook
Dim counter As Long, last_row As Long, last_col As Long
Dim i, j, k As Integer
Dim data() As String

counter = 1

open_close

Query_Tv_values

For Each wb In Workbooks
    If wb.Name <> ThisWorkbook.Name Then
        MsgBox "working on " & wb.Name
        PerLineItem2 wb
        Threshold_Value_PayFull wb
    End If
Next
'It's just the part below which I'm having issues with :(

Set book = Workbooks.Add
Set ws = book.Sheets.Add(book.Sheets(1))
ws.Name = "Report_Final"

For Each wb In Workbooks
    If (wb.Name <> ThisWorkbook.Name Or wb.Name <> book.Name) Then
        Extract_Report_Final wb, counter, book
        counter = counter + 1
Next wb

End Sub

Answer 1

Just use something like this to fill out the values in your new workbook

    Cells(counter, i).Value = data(i-1)

Check the size of you array vs the length of your loops though - I think the "i"-loop should go

For i = 1 To last_col -1