-1

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

大多数定义的名称区域都是 1 行高（数百列宽）......但少数是 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

对于区域为 1 行高的情况，我编写了一些 VBA/VBS 可以完美地工作（而且速度很快！），但我不确定如何以有效的方式处理对较高区域的求和。

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

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

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
4

3 回答 3

2

您可以更新代码，使其添加给定范围 ( 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
于 2013-10-28T09:22:11.350 回答
1

没有最好的方法，因为每个人都可能认为他们的方法是最好的。

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

考虑

在此处输入图像描述

现在运行代码

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

结果是

在此处输入图像描述

使用数组的想法取自这里

你需要做的就是修改你想要重新打印数组的范围

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

因此，如果您使用上面的代码，我认为您需要更改的只是

wsDest.Range("A3").Resize(1, UBound(finalArray, 1) + 1) = finalArray
于 2013-10-28T09:33:07.410 回答
0

这是我最后使用的代码：它循环遍历定义的命名范围的每一列。它并不快，但效果很好，因为我 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
于 2013-10-29T05:25:40.397 回答