Question

源工作簿的工作表包含32列，并且数字行是动态的。将有一个值为“ Y”或“ N”的列。对于每个“ Y”，我需要将该行写入数组，甚至是空单元格。列标题的开头是单元格“ A6”，详细信息位于“ A7”。

下一步，将数组粘贴到其他工作表中的实际表中。这将定期发生，并且当用户更新源时，将需要在表中替换这些值。

从源创建数组
清除目标工作表中的表格
将数组粘贴到目标工作表中的表中

问题是我在数组中没有值，而且我仍在尝试一般地掌握数组，因此将不胜感激。下面的代码来自我为测试目的而研究的一小部分。

    Sub CopyToDataset()


    Dim datasetWs As Worksheet
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim cell As Range, rng1 As Range, rng2 As Range, row As Range
    Dim ArrayofAJobs() As Variant
    Dim ArrayofACCJobs() As Variant
    Dim myData As Range
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim LastRowWs1 As Long
    Dim LastRowWs2 As Long

    Set ws1 = ThisWorkbook.Worksheets("Src")
     ' Find the last row with data.
    LastRowWs1 = LastRow(ws1)


    k = 1
    With ws1
    ReDim ArrayofAJobs(6, k)
    For i = 2 To LastRowWs1
    If UCase(Cells(i, 1)) = "Y" Then
        For j = 2 To 4
            If IsNull(ArrayofAJobs(j, k)) Then ArrayofAJobs(j, k) = vbNullString
            ArrayofAJobs(j, k) = Cells(i, j).Value
        Next j
        k = k + 1
        ReDim Preserve ArrayofAJobs(4, k)
    End If
    Next i
    End With


    ArrayofAJobs() = TransposeArray(ArrayofAJobs)

    With ThisWorkbook.Worksheets("Dest")
        .Range("A6") = ArrayofAJobs()
    End With
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).row
    On Error GoTo 0
End Function


Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
    Xupper = UBound(myarray, 2)
    Yupper = UBound(myarray, 1)
    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = myarray(Y, X)
        Next Y
    Next X
    TransposeArray = tempArray
End Function

================================================ ====================

版本2：运行时错误9：下标超出范围。

样本来源：

Option Explicit
Option Base 1

Sub CopyToDataset()

 Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim destWkb As Workbook
    Dim cell As Range, rng1 As Range, rng2 As Range, row As Range
    Dim ArrayofAJobs() As Variant
    Dim ArrayofACCJobs() As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim LastRowWs1 As Long
    Dim LastRowWs2 As Long
    k = 1
    Const startRow As Long = 6


    Set ws1 = ThisWorkbook.Worksheets("Src")

     ' Find the last row with data on ws1.
    LastRowWs1 = LastRow(ws1)
    Debug.Print LastRowWs1


    With ws1
    ReDim ArrayofAJobs(i, 32)
    For i = 1 + startRow To LastRowWs1 'Number of rows starting at row 6. Details start on row 7.
    If UCase(.Cells(i, 1)) = "Y" Then
        For j = 1 To 32 'Number of columns starting on column A
            If IsNull(ArrayofAJobs(i, j)) Then ArrayofAJobs(i, j) = vbNullString
            ArrayofAJobs(i, j) = .Cells(i, j).Value
        Next j
    End If
    Next i
    End With

    With ThisWorkbook.Worksheets("Dest")
        .Range(.Cells(2, 1), .Cells(UBound(ArrayofAJobs, 1), UBound(ArrayofAJobs, 2))) = ArrayofAJobs()
    End With
End Sub

Answer 1

在没有看到工作簿的情况下，我不确定100％确切地跟随了您，但是我确实看到了一些我会改变的事情。

您需要添加一个“。”在Cells之前。该点确保您要拾取的单元格来自ws1，而不是活动工作表。
```
If UCase(.Cells(i, 1)) = "Y" Then    

    ArrayofAJobs(j, k) = .Cells(i, j).Value
```
监视窗口没有扩展任何数组元素，因此我们看不到数组实际上为空。但是，您不能Redim Preserve数组的第一维。
```
ReDim ArrayofAJobs(6, k)

ReDim Preserve ArrayofAJobs(4, k)   'This line should cause a Runtime Error 9.
```
您似乎需要将第一个ReDim更改为ArrayofAJobs(**4**, k)。
“粘贴”数组时，必须指定要“粘贴”到的整个范围。这不像粘贴一系列复制的单元格，您可以在其中告诉Excel顶部，左侧的单元格，然后找出其余部分。因此，您需要从以下位置更改代码
```
.Range("A6") = ArrayofAJobs()
```
对此。
```
.Range(.Cells(6, 1), .Cells(UBound(ArrayofAJobs, 1), UBound(ArrayofAJobs, 2))) = ArrayofAJobs
```

在条件上创建动态数组并将其粘贴到工作表

1 个答案: