求助：如何在Bloomberg相关VBA数组中移除空单元格？

当前输出（列间因空单元格产生过大间距）：

x1  x2  x3       x5        x4
v1  v2  v3       v5        v4

期望输出（列紧凑排列）：

x1  x2  x3  x5  x4
v1  v2  v3  v5  v4

我的VBA代码如下：

Sub CopyPaste()

Sheets("EUR").Range("AF44:AG193").Copy
Range("AL44:AM193").PasteSpecial xlPasteValues

Sheets("EUR").Range("AL8:AL17").Copy
Range("AM8:AM17").PasteSpecial xlPasteValues

Sheets("EUR").Range("AP41:BD42").ClearContents


   
    ' create wrapper object
    Set b = New BCOM_wrapper
    '
    ' create securities vector
    'determine length
    Dim x As Long
    x = 14

    'redim vector s to length and fill
    ReDim s(0 To x)
    For x = 1 To UBound(s) + 1
            s(x - 1) = Cells(42 + x, 1)
    Next x
    
    
    ' create fields vector
    
    Dim y As Long
    y = 1
    
    Do While Cells(39, y + 1) <> ""
    y = y + 1
    Loop
    
    ReDim f(0 To y - 2)
    For y = 1 To UBound(f) + 1
            f(y - 1) = Cells(39, 1 + y)
    Next y
    '
    ' retrieve result from wrapper into array and print
    r = b.referenceData(s, f)

    Dim i As Long
    Dim j As Long
    On Error Resume Next
    For j = 0 To UBound(r, 1)
        For i = 0 To UBound(r, 2)
            Cells(i + 41, j + 42) = r(j, i)
        Next i
    Next j

    ' release wrapper object
    Set b = Nothing

End Sub

我尝试将空单元格移至列右侧或从数组中直接移除，但未找到有效方案。注：r = b.referenceData(s, f)调用Bloomberg API的部分无需修改。

解决方案 #

方案1：从数组层面过滤空列

在将数组r写入工作表前，先过滤掉所有值为空的列，直接生成紧凑的结果数组：

' 替换原代码中数组写入的循环部分
Dim filteredArr As Variant
Dim colCount As Long, newColIdx As Long, rowCount As Long
rowCount = UBound(r, 2) + 1
colCount = UBound(r, 1) + 1

' 第一步：统计非空列的数量
newColIdx = 0
For j = 0 To UBound(r, 1)
    Dim isColEmpty As Boolean
    isColEmpty = True
    For i = 0 To UBound(r, 2)
        If r(j, i) <> "" Then
            isColEmpty = False
            Exit For
        End If
    Next i
    If Not isColEmpty Then newColIdx = newColIdx + 1
Next j

' 第二步：初始化过滤后的数组
ReDim filteredArr(0 To newColIdx - 1, 0 To rowCount - 1)
newColIdx = 0

' 第三步：填充过滤后的数组
For j = 0 To UBound(r, 1)
    Dim isColEmpty2 As Boolean
    isColEmpty2 = True
    For i = 0 To UBound(r, 2)
        If r(j, i) <> "" Then
            isColEmpty2 = False
            Exit For
        End If
    Next i
    If Not isColEmpty2 Then
        For i = 0 To UBound(r, 2)
            filteredArr(newColIdx, i) = r(j, i)
        Next i
        newColIdx = newColIdx + 1
    End If
Next j

' 第四步：将过滤后的数组写入工作表
Range(Cells(41, 42), Cells(41 + rowCount - 1, 42 + newColIdx - 1)) = WorksheetFunction.Transpose(filteredArr)

方案2：写入后整理列（将空列移至右侧）

如果不想修改数组处理逻辑，可在数据写入完成后，批量将空列移到目标区域的最右侧：

' 在原代码的Set b = Nothing之后添加以下代码
Dim targetRange As Range
Set targetRange = Range(Cells(41, 42), Cells(193, 42 + UBound(r, 1))) ' 根据实际数据范围调整上下限

Dim col As Range, emptyCols As Collection
Set emptyCols = New Collection

' 收集所有空列
For Each col In targetRange.Columns
    If WorksheetFunction.CountA(col) = 0 Then
        emptyCols.Add col
    End If
Next col

' 反向遍历将空列移到区域右侧
For i = emptyCols.Count To 1 Step -1
    emptyCols(i).Cut
    targetRange.Columns(targetRange.Columns.Count + 1).Insert Shift:=xlToRight
Next i

内容的提问来源于stack exchange，提问作者Erik Engström