Создание одного массива, состоящего из нескольких значений диапазона из разных листов в Excel VBA - PullRequest
Новая
       10

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

0 голосов
/ 18 января 2020

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

В настоящее время это то, что у меня есть. 


Sub Test()

Workbooks.Open("dataex.xlsx").Activate
Dim i, x, y, z, sheet_num

Dim allsheets As Variant

Dim sheet As Variant
Dim sheets As Variant '

Dim list As Variant

Dim ws As Worksheet
i = Application.sheets.Count

x = 1
ReDim allsheets(1 To i)

For Each ws In Worksheets
    allsheets(x) = ws.Name
    x = x + 1
Next ws

sheets = allsheets
For Each sheet In sheets

tmp = Range("A2").CurrentRegion.Value

y = Range("A1").CurrentRegion.Rows.Count
z = Range("A1").CurrentRegion.Columns.Count

list = Range(Cells(1, 1), Cells(y, z))

Next sheet

End Sub

Я приложил картинку, чтобы показать поддельные данные, которые я создал (те же данные на каждом листе для простоты)

enter image description here В конце я хотел бы получить массив с именем list равным количеству столбцов z, но строки значений будут добавлены друг под другом, а затем изменить размер массива и добавьте лист с.

enter image description here

1 Ответ

1 голос
/ 18 января 2020

Я делал нечто подобное раньше, и это выглядело так: 

Sub Test()

    Dim i As Long, wb As Workbook, data(), numSheets As Long
    Dim rng As Range, numCol As Long, totRows As Long, allData()
    Dim rw As Long, col As Long, arr, r As Long, firstSheet As Boolean

    Set wb = Workbooks.Open("dataex.xlsx")
    numSheets = wb.Worksheets.Count

    ReDim data(1 To numSheets)
    firstSheet = True 'controls whether we skip the header row

    'loop over the sheets and collect the data
    For i = 1 To numSheets
        Set rng = wb.Worksheets(i).Range("A1").CurrentRegion
        'ignore empty sheets
        If Application.CountA(rng) > 0 Then
            'remove the header if not first sheet
            If Not firstSheet Then Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
            data(i) = rng.Value                     'collect the data
            totRows = totRows + UBound(data(i), 1)  'add the row count
            firstSheet = False 'done one sheet
        End If
    Next i

    'size the final output array
    ReDim allData(1 To totRows, 1 To UBound(data(1), 1))

    r = 1
    'combine the array from each sheet into the final array
    For i = 1 To numSheets
        If Not IsEmpty(data(i)) Then 'sheet had data?
            arr = data(i)
            For rw = 1 To UBound(arr, 1)
                For col = 1 To UBound(arr, 2)
                    allData(r, col) = arr(rw, col)
                Next col
                r = r + 1
            Next rw
        End If
    Next i

    'add a new sheet and dump the array
    With wb.sheets.Add(after:=wb.sheets(wb.sheets.Count))
        .Range("A1").Resize(totRows, UBound(allData, 2)).Value = allData
    End With

End Sub
...