今天我开始在VBA学习阵列。
尝试了一些简单的脚本后，我想创建一个对我的项目有用的脚本。
在我的excelsheet中，我有一个需要转换为新工作表的数据表。仅适用于具有＆＃34;详细信息＆＃34;在第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
我手动执行了两次动作，我的结果应该是什么样子。 也许有更好或更简单的方法，但我认为数组可以完美地适应这项工作。
提前致谢！
答案 0 :(得分：3)
使用Dynamic变量数组更简单。
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
答案 1 :(得分：3)
您的代码存在一些问题（请注意那些不合格的范围），但主要的一点是您将数组索引与单元格行和列引用混淆，正如您所指出的那样，有一些冗余代码，您可以在其中维护数组。使用多维数组时，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