Question

我有一个工作簿，其中有数千个已定义的名称区域位于各种工作表中。我正在尝试将它们全部解压缩并将它们排列在另一个工作簿中。

大多数已定义的名称区域都是1行高（以及数百个cols宽）...但有一些是3-4行高。

例如，

名1

10 5 10 12 30 10 12 10 5 10 12 30 10 12 ...

名称2

10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...
10 11 10 12 30 10 12 10 11 10 12 30 10 12 ...

对于区域高度超过一行的情况，我想通过获取整列的SUM将其折叠为单行。

因此 Name2 将被复制到新工作簿中，如下所示：

30 33 30 36 90 30 36 30 33 30 36 90 30 36

我有一些VBA / VBS编写完美（并且快！）适用于区域高1行的情况，但我不知道如何以有效的方式处理较高的区域。

填写下面问号的最佳方法是什么？

到目前为止，我的代码不必明确地循环遍历区域的单元格;我希望在这里也不会出现这种情况。任何建议表示赞赏！

Dim irow
irow = 0
Dim colsum

'rem Loop through all names and copy over the valid ones
For Each nm in wbSource.Names

    'rem Dont copy any name that isnt visible
    If nm.Visible = True Then

        'rem Only copy valid references that start with "ByWeek"
        If InStr(1, nm.RefersTo, "#REF") = 0 And InStr(1, nm.Name, "ByWeek") > 0 Then

            'rem Only copy if the range is one row tall
            If nm.RefersToRange.Row.Count = 1 Then
                wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
                wsDest.Range("A3",wsDest.Cells(3,nm.RefersToRange.Columns.Count+1)).Offset(irow, 1).Value = nm.RefersToRange.Value
                irow = irow + 1     

            ' rem If the named region is several rows tall, then squish it into one row by taking SUM of each column
            elseif  nm.RefersToRange.Row.Count > 1 Then
                wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
                ???????????????????????????????????
                irow = irow + 1                     

            End If      
        End If  
    End if
Next

Answer 1

您可以更新代码，使其添加给定范围内的所有单元格（nm.RefersToRange），与单元格数量无关：

Dim irow
irow = 0

'rem Loop through all names and copy over the valid ones
For Each nm in wbSource.Names

    'rem Dont copy any name that isnt visible
    If nm.Visible = True Then

        'rem Only copy valid references that start with "ByWeek"
        If InStr(1, nm.RefersTo, "#REF") = 0 And InStr(1, nm.Name, "ByWeek") > 0 Then
            If nm.RefersToRange.Rows.Count >= 1 Then
                wsDest.Range("A3").Offset(irow, 0).Value = nm.Name
                Dim totVal As Long: totVal = 0   'I assumed that target values are Long; update this to the proper type is required
                For Each cell In nm.RefersToRange.Cells
                    If (IsNumeric(cell.Value)) Then totVal = totVal + cell.Value
                Next
                wsDest.Range("A3", wsDest.Cells(3, nm.RefersToRange.Columns.Count + 1)).Offset(irow, 1).Value = totVal
                irow = irow + 1  
            End If  
        End If  
    End if
Next

Answer 2

没有最佳方式，因为每个人都认为他们的方式是最佳。

我建议使用数组而不是直接使用范围对象，因为数组会更快。

考虑

enter image description here

现在运行代码

Option Explicit

Sub Main()

    Dim lastRow As Long
    Dim lastCol As Long

    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

    Dim arr As Variant
    arr = Range(Cells(1, 1), Cells(lastRow, lastCol))

    ReDim sumArr(UBound(arr, 2)) As Variant
    Dim i As Long
    Dim j As Long
    Dim colSum As Long

    For i = LBound(arr, 1) To UBound(arr, 2)
        For j = LBound(arr, 1) To UBound(arr, 1)
            colSum = colSum + arr(j, i)
        Next j
        sumArr(i) = colSum
        colSum = 0
    Next i

    ReDim finalArray(UBound(sumArr) - 1) As Variant
    For i = 1 To UBound(sumArr)
        finalArray(i - 1) = sumArr(i)
    Next i

    Range("A10").Resize(1, UBound(finalArray, 1) + 1) = finalArray

End Sub

结果

enter image description here

使用数组的想法取自here

您需要做的就是将要重新打印数组的范围修改为

Range("A10").Resize(1, UBound(finalArray, 1) + 1) = finalArray

因此，如果您使用上述代码，我认为您需要更改的内容将是

wsDest.Range("A3").Resize(1, UBound(finalArray, 1) + 1) = finalArray

Answer 3

这是我结束使用的代码：它遍历定义的命名范围的每一列。它并不快，但效果还不错，因为90％的范围只有一行高。

我刚刚在上面的问题中将此代码插入到????...????的位置：

                        For j = 1 To nm.RefersToRange.Columns.Count
                            colsum  = 0
                            For i = 1 To nm.RefersToRange.Rows.Count
                              If IsNumeric(nm.RefersToRange.Cells(i, j).Value) Then                  
                                    colsum = colsum + nm.RefersToRange.Cells(i, j).Value
                              End If                  
                            Next
                            wsDest.Range("A3").Offset(irow, j).Value = colsum
                        Next

命名区域中列值的总和

3 个答案: