Excel VBA - 将数据写入数组不起作用

Question

今天我开始学习 VBA 中的数组。

在尝试了一些简单的脚本后，我想创建一个对我的项目有用的脚本。

在我的 excelsheet 中，我有一个需要转换为新工作表的数据表。仅适用于第 4 行中具有“详细信息”的每一列。

最简单的想象方法是将每个相关列的值写入数组，读取结果并将其写入新工作表，然后再次执行操作。

但我认为我使用错误的方法将变量写入我的数组。 我查看了我的代码，我的所有声明都不正确。

您能帮帮我吗，我怎样才能正确更改对数组的写入？

Sub Import_data()

Dim LastCol As Integer
Dim LastRow As Long
Dim WS As Worksheet
Dim Arr() As Variant
Dim dim1 As Long, dim2 As Long

Set WS = Sheets("Budget to Table")



' Copy data from Budget to Table
    With WS
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        dim1 = .Cells(.Rows.Count, "B").End(xlUp).Row - 5
        dim2 = 4

    ' Copy information
        For i = 3 To LastCol
            If Cells(4, i).Value = "Detail" Then

                ReDim Arr(0 To dim1, 0 To dim2)

                    For dim1 = LBound(Arr, 1) To UBound(Arr, 1)
                        For dim2 = LBound(Arr, 2) To UBound(Arr, 2)
                            Arr(dim1, 0) = Range(Cells(dim1, 2)) 'Should have the variable length but always column B
                            Arr(dim1, 1) = Range(Cells(dim1, i)) 'Should have the variable length but always column i
                            Arr(dim1, 2) = Range(Cells(1, i)) 'Is always the same header info from row 1 of the chosen column
                            Arr(dim1, 3) = Range(Cells(2, i)) 'Is always the same header info from row 2 of the chosen column
                            Arr(dim1, 4) = Range(Cells(3, i)) 'Is always the same header info from row 3 of the chosen column
                        Next dim2
                    Next dim1

            End If

            'writing the contents in a new sheet
            Worksheet.Add
                For dim1 = LBound(Arr, 1) To UBound(Arr, 1)
                    For dim2 = LBound(Arr, 2) To UBound(Arr, 2)
                        ActiveCell.Offset(dim1, dim2).Value = Arr(dim1, dim2)
                    Next dim2
                Next dim1
            Erase Arr
        Next i
    End With

End Sub

如果我需要提供更多指导，请告诉我。 我猜dim1 和dim2 的值永远不会改变，所以这不会创建我所追求的循环。

编辑：我在这里上传了文件：https://dubblej15.stackstorage.com/s/C0DrKzFDxn4gY4U

我手动执行了两次操作，我的结果应该是这样的。 也许有更好或更简单的方法，但我认为数组可以完美地适应这项工作。

提前致谢！

Answer 1

您的代码存在一些问题（请注意那些不合格的范围），但主要问题是您将数组索引与单元格行和列引用混合在一起，正如您所指出的，有一些冗余代码可以在其中对数组进行标注。 Redim Preserve 在使用多维数组时也有限制。

因此，下面是您的代码的修改版本，其中显示了所需的调整。

但是，如果您想使用数组，那么您的效率会更高。例如，您可以只用一行代码将范围读入数组并从数组写入范围（这比使用循环快得多）。第二段代码向您展示了一种更有效的处理任务的方法 - 我不确定您的示例行是否都会在“A”列中包含“详细信息”，因为如果它们没有中断，那么代码可能是均匀的更短。

您修改后的代码：

Dim dataWs As Worksheet, newWs As Worksheet
Dim lastRow As Long, lastCol As Long
Dim c As Long, r As Long, i As Long, j As Long
Dim arr() As Variant

'Read the data into an array
Set dataWs = ThisWorkbook.Worksheets("Budget to Table")
With dataWs
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With

'Loop through each of the data columns.
For c = 3 To lastCol
    If Not IsEmpty(dataWs.Cells(3, c)) Then 'looks lik you only want the yellow columns.
        'Dimension the array for number of rows
        ReDim arr(1 To lastRow - 4, 1 To 5)
        'Loop through each row in data array and transfer it.
        With dataWs
            For r = 5 To lastRow
                arr(r - 4, 1) = .Cells(r, 2).Value
                arr(r - 4, 2) = .Cells(r, c).Value
                arr(r - 4, 3) = .Cells(1, c).Value
                arr(r - 4, 4) = .Cells(2, c).Value
                arr(r - 4, 5) = .Cells(3, c).Value
            Next
        End With
        'Create a new sheet.
        With ThisWorkbook.Worksheets
            Set newWs = .Add(After:=.Item(.Count))
            newWs.Name = arr(1, 5) 'name it for ease of use.
        End With
        'Write array onto the new sheet - the inefficient way
        For i = 1 To UBound(arr, 1)
            For j = 1 To UBound(arr, 2)
                newWs.Cells(i, j).Value = arr(i, j)
            Next
        Next
    End If
Next

处理数组的不同方式：

Dim ws As Worksheet
Dim data As Variant, output() As Variant
Dim rowList As Collection
Dim c As Long, i As Long
Dim r As Variant

'Read the data into an array
With ThisWorkbook.Worksheets("Budget to Table")
    data = .Range(.Range("A1"), _
           .Range(.Cells(1, .Columns.Count).End(xlToLeft), _
                  .Cells(.Rows.Count, "B").End(xlUp))) _
           .Value2
End With

'Find the first dimension indexes with "Detail" in column A.
'We'll create a collection of our target row numbers.
Set rowList = New Collection
For i = 1 To UBound(data, 1)
    If data(i, 1) = "Detail" Then rowList.Add i
Next

'Loop through each of the data columns.
For c = 3 To UBound(data, 2)
    If Not IsEmpty(data(3, c)) Then 'looks lik you only want the yellow columns.
        'Dimension the array for number of rows
        ReDim output(1 To rowList.Count, 1 To 5)
        i = 1 'row index for output array
        'Loop through each row in data array and transfer it.
        For Each r In rowList
            output(i, 1) = data(r, 2)
            output(i, 2) = data(r, c)
            output(i, 3) = data(1, c)
            output(i, 4) = data(2, c)
            output(i, 5) = data(3, c)
            i = i + 1
        Next
        'Create a new sheet.
        With ThisWorkbook.Worksheets
            Set ws = .Add(After:=.Item(.Count))
            ws.Name = output(1, 5) 'name it for ease of use.
        End With
        'Write array onto the new sheet.
        ws.Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output
    End If
Next

Answer 2

使用动态变体数组更简单。

Sub Import_data()

Dim LastCol As Integer
Dim LastRow As Long
Dim WS As Worksheet
Dim Arr() As Variant, vDB As Variant
Dim i As Integer, j As Long, n As Long

Set WS = Sheets("Budget to Table")

' Copy data from Budget to Table
    With WS
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        vDB = .Range("a1", .Cells(LastRow, LastCol)) '<~~ get data to vDB variant array from range

    ' Copy information
        For i = 3 To LastCol
            n = 0
            If vDB(4, i) = "Detail" Then
                For j = 5 To UBound(vDB, 1)
                    n = n + 1
                    ReDim Preserve Arr(1 To 5, 1 To n) '<~set dynamic variant array which is to be transposed.
                    Arr(1, n) = vDB(j, 2)
                    Arr(2, n) = vDB(j, i)
                    Arr(3, n) = vDB(1, i)
                    Arr(4, n) = vDB(2, i)
                    Arr(5, n) = vDB(3, i)
                Next j
                'writing the contents in a new sheet
                Worksheets.Add after:=Sheets(Sheets.Count)
                Range("a1").Resize(n, 5) = WorksheetFunction.Transpose(Arr)
                ReDim Arr(1 To 5, 1 To 1)
            End If


        Next i
    End With

End Sub