如果column中的值为空，则从2d数组中删除行

Question

我有一张很大的实验室测量日志表，可以使用数组进行工作。 （我是化学家，实验室技术员，Ive上周才开始学习VBA，请耐心等待。）我试图弄清楚如何将表加载到数组中，然后删除第5列中具有空值的行这样我就可以通过数组将第5列中没有空格的表“导出”到另一个工作表中。

我首先用为一维数组找到的一些代码对此进行了测试，在该代码中，我将创建2个数组，一个占位符数组，通过将非空白添加到第二个数组来进行ID循环。

For Counter = LBound(TestArr) To UBound(TestArr)
    If TestArr(Counter, 1) <> "" Then
        NoBlankSize = NoBlankSize + 1
        NoBlanksArr(UBound(NoBlanksArr)) = TestArr(Counter, 1)
        ReDim Preserve NoBlanksArr(0 To UBound(NoBlanksArr) + 1)
    End If
Next Counter

它可以在1D模式下工作，但是我似乎无法在2D尺寸下完成两项工作。

继承数组Im用于读取和输出数据

Sub ArrayTest()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim TestArray() As Variant
    Dim Dimension1 As Long, Dimension2 As Long

    Sheets("Tracker").Activate

    Dimension1 = Range("A3", Range("A2").End(xlDown)).Cells.Count - 1
    Dimension2 = Range("A2", Range("A2").End(xlToRight)).Cells.Count - 1

    ReDim TestArray(0 To Dimension1, 0 To Dimension2)

    'load into array
    For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
        For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
            TestArray(Dimension1, Dimension2) = Range("A4").Offset(Dimension1, Dimension2).Value
        Next Dimension2
    Next Dimension1

    Sheets("Output").Activate
    ActiveSheet.Range("A2").Select

    'read from array
    For Dimension1 = LBound(TestArray, 1) To UBound(TestArray, 1)
        For Dimension2 = LBound(TestArray, 2) To UBound(TestArray, 2)
             ActiveCell.Offset(Dimension1, Dimension2).Value = TestArray(Dimension1, Dimension2)
        Next Dimension2
    Next Dimension1

    Erase TestArray

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

感谢您的任何帮助。

Answer 1

如果要更改记录数（行），则Redim Preserve语句不适用于二维数组。

您可以将范围加载到数组中，然后在要将数组导出到另一个范围时，在跳过空白记录的同时循环遍历该数组。

一个例子：

Option Explicit

Sub ArrayTest()
Dim wb As Workbook, wsInput As Worksheet, wsOutput As Worksheet
Dim myArr As Variant
Dim i As Long, k As Long, LRow As Long

Set wb = ThisWorkbook
Set wsInput = wb.Sheets("Tracker")
Set wsOutput = wb.Sheets("Output")

LRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row + 1

'Load a range into the array (example range)
myArr = wsInput.Range("A1:Z100")

'Fill another range with the array
For i = LBound(myArr) To UBound(myArr)
    'Check if the first field of the current record is empty
    If Not Len(myArr(i, 1)) = 0 Then
        'Loop through the record and fill the row
        For k = LBound(myArr, 2) To UBound(myArr, 2)
            wsOutput.Cells(LRow, k) = myArr(i, k)
        Next k
        LRow = LRow + 1
    End If
Next i

End Sub

Answer 2

从您的代码看来，您想要

• 在工作表上测试一列数据，看是否有空白。
• 如果特定列中有空白，则排除该行
• 将排除行中的数据复制到新区域

您可能可以使用过滤器来做到这一点（更快）： 下面的代码检查column2中的空白

Option Explicit
Sub removeCol2BlankRows()

    Dim wsSrc As Worksheet, wsRes As Worksheet
    Dim rSrc As Range, rRes As Range

Set wsSrc = ThisWorkbook.Worksheets("sheet1")
  Set rSrc = wsSrc.Cells(1, 1).CurrentRegion 'many ways to do this

Set wsRes = ThisWorkbook.Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 10)

If wsSrc.AutoFilterMode = True Then wsSrc.AutoFilterMode = False

rSrc.AutoFilter field:=2, Criteria1:="<>"
rSrc.SpecialCells(xlCellTypeVisible).Copy rRes

wsRes.AutoFilterMode = False

End Sub

如果您真的只想过滤代码中的VBA数组，则将非空行存储在字典中，然后将其写回到新数组中：

Option Explicit
Sub removeCol2BlankRows()
    Dim testArr As Variant
    Dim noBlanksArr As Variant
    Dim myDict As Object
    Dim I As Long, J As Long, V
    Dim rwData(1 To 4) As Variant

With ThisWorkbook.Worksheets("sheet1")
    testArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
End With

Set myDict = CreateObject("Scripting.Dictionary")

For I = 1 To UBound(testArr, 1)
    If testArr(I, 2) <> "" Then
        For J = 1 To UBound(testArr, 2)
            rwData(J) = testArr(I, J)
        Next J
        myDict.Add Key:=I, Item:=rwData
    End If
Next I

ReDim noBlanksArr(1 To myDict.Count, 1 To 4)
I = 0
For Each V In myDict.keys
    I = I + 1
    For J = 1 To 4
        noBlanksArr(I, J) = myDict(V)(J)
    Next J
Next V
End Sub