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

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

在尝试了几个简单的脚本之后，我想创build一个对我的项目很有用的脚本。

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

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

但我想我正在使用一个错误的方法将variables写入我的数组。 我翻遍了我的代码，所有的错误都是不正确的。

你能帮我，我怎么可以改变写入数组正确？

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的值永远不会改变，所以这不会创build我后面的循环。

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

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

提前致谢！

Answer 1

你的代码有几个问题（注意那些不合格的范围），但最主要的是你得到的数组索引与单元格行和列引用混合在一起，正如你指出的那样，有一个less量的冗余代码，你维度你的arrays。 使用multidimensional array时， 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

使用dynamicvariables数组更简单。

 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