从单独的工作表中合并动态命名范围

如何解决从单独的工作表中合并动态命名范围

我最初的理解是，我或许可以使用 Union 来解决这个问题：

我在工作簿的不同页面上为各种产品类型设置了不同的动态命名范围。所有这些都具有相同的起始单元格和列属性，但长度因输入数据而异。有没有一种简单的方法可以将这些条目自动汇集到一个综合列表中？这些不是格式化的表格，我宁愿避免将它们制作成图表。

例如：工作表 1 包含两个产品 (B2:B3) 的列表，并在 C 和 D 列中包含相关的收入和成本数字。工作表 2 包含三个产品 (B2:B4) 的列表，其中...喜欢让工作表 3 自动更新为 (B2:B6) 和 C 列和 D 列，其中包含来自原始 2 个工作表的数据。这些数据会不断增长并会定期更改。

解决方法

这是一种模拟 UNION 的方法

=LET(
data1,FILTER('Worksheet 1'!B:D,'Worksheet 1'!B:B<>""),data2,FILTER('Worksheet 2'!B:D,'Worksheet 2'!B:B<>""),rows1,ROWS(data1),rows2,ROWS(data2),cols1,COLUMNS(data1),rowindex,SEQUENCE(rows1+rows2),colindex,SEQUENCE(1,cols1),IF(
rowindex<=rows1,INDEX(data1,colindex),INDEX(data2,rowindex-rows1,colindex))
)

,

我知道我的代码可能非常低效 - 我仍处于学习的开始阶段......由于我无法弄清楚这个“联合”的事情，我最终运行了以下代码：

Sub dynamicRangeCons()

Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False

    Dim startCell As Range,lastRow As Long,lastCol As Long,ws0 As Worksheet,ws1 As Worksheet
    Dim ConsItem As String
    
    Set ws = Worksheets("Cons Ingredients Listing")
    ws.Activate
    Set startCell = ws.Range("B3")
    
    Set ws0 = ThisWorkbook.Sheets("Cons Ingredients Listing")
    Set ws1 = ThisWorkbook.Sheets("Spirits Ingredients Listing")
    Set ws2 = ThisWorkbook.Sheets("Beer Ingredients Listing")
    Set ws3 = ThisWorkbook.Sheets("Misc Ingredients Listing")
    Set ws4 = ThisWorkbook.Sheets("Wine Ingredients Listing")
    Set ws5 = ThisWorkbook.Sheets("NA Ingredients Listing")
    
        lastRow = ws.Cells(ws.Rows.Count,startCell.Column).End(xlUp).Row
        lastCol = ws.Cells(startCell.Row,startCell.Column).End(xlToRight).Column
        
    ws.Range(startCell,ws.Cells(lastRow,lastCol)).Clear
    
    ws1.Range("SpiritsItem").Copy ws0.Range("B3")
    ws1.Range("Spirits").Copy ws0.Range("C3")
    
        lastRow = ws.Cells(ws.Rows.Count,startCell.Column).Column
    
    ws2.Range("BeerItem").Copy ws.Cells(lastRow + 1,lastCol)
    ws2.Range("Beer").Copy ws.Cells(lastRow + 1,lastCol + 1)
    
        lastRow = ws.Cells(ws.Rows.Count,startCell.Column).Column
    
    ws3.Range("MiscItem").Copy ws.Cells(lastRow + 1,lastCol)
    ws3.Range("Misc").Copy ws.Cells(lastRow + 1,startCell.Column).Column
    
    ws4.Range("WineItem").Copy ws.Cells(lastRow + 1,lastCol)
    ws4.Range("Wine").Copy ws.Cells(lastRow + 1,startCell.Column).Column
    
    ws5.Range("NAItem").Copy ws.Cells(lastRow + 1,lastCol)
    ws5.Range("NA").Copy ws.Cells(lastRow + 1,lastCol + 1)

        lastRow = ws.Cells(ws.Rows.Count,startCell.Column).Column
        
    ws.Range(startCell,lastCol)).Select

    ThisWorkbook.Names.Add Name:="ConsItem",RefersTo:=Selection

        lastRow = ws.Cells(ws.Rows.Count,startCell.Column).End(xlToRight).Column
        
    ws.Range(ws.Cells(startCell.Row,startCell.Column + 1),lastCol)).Select

    ThisWorkbook.Names.Add Name:="Cons",RefersTo:=Selection

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

结束子

,

合并工作表

• 将以下内容复制到标准模块中，例如Module1。
• 调整常量部分中的值。

Option Explicit

Sub ConsolidateProducts()
    
    Const sNamesList As String = "Sheet1,Sheet2"
    Const sFirst As String = "B2:D2"
    Const dName As String = "Sheet3"
    Const dFirst As String = "B2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sNames() As String: sNames = Split(sNamesList,",")
    Dim nUpper As Long: nUpper = UBound(sNames)
    Dim nCount As Long: nCount = -1
    Dim sData As Variant: ReDim sData(0 To nUpper)
    Dim rData() As Long: ReDim rData(0 To nUpper)
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim sfrrg As Range
    Dim slCell As Range
    Dim srCount As Long
    Dim drCount As Long
    Dim n As Long
    
    For n = 0 To nUpper
        Set sws = wb.Worksheets(sNames(n))
        Set sfrrg = sws.Range(sFirst)
        Set slCell = Nothing
        Set slCell = sfrrg.Resize(sws.Rows.Count - sfrrg.Row + 1) _
                .Find("*",xlFormulas,xlByRows,xlPrevious)
        If Not slCell Is Nothing Then
            nCount = nCount + 1
            srCount = slCell.Row - sfrrg.Row + 1
            Set srg = sfrrg.Resize(srCount)
            sData(nCount) = srg.Value
            rData(nCount) = srCount
            drCount = drCount + srCount
        End If
    Next n
    
    If nCount = -1 Then Exit Sub
    
    Dim cCount As Long: cCount = sfrrg.Columns.Count
    Dim dData As Variant: ReDim dData(1 To drCount,1 To cCount)
    
    Dim s As Long,d As Long,c As Long
    
    For n = 0 To nCount
        For s = 1 To rData(n)
            d = d + 1
            For c = 1 To cCount
                dData(d,c) = sData(n)(s,c)
            Next c
        Next s
    Next n
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
    Dim dfrrg As Range: Set dfrrg = dfCell.Resize(,cCount)
    
    Dim drg As Range: Set drg = dfrrg.Resize(drCount)
    drg.Value = dData
    
    Dim dcrg As Range: Set dcrg = dfrrg _
        .Resize(dws.Rows.Count - dfrrg.Row - drCount - 1).Offset(drCount)
    dcrg.ClearContents

End Sub

• 如果所有数据都是值，那么为了自动执行前面的操作，请将以下内容复制到每个源模块（而不是目标（结果）工作表）中。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const sFirst As String = "B2:D2"
    
    Dim srg As Range
    With Range(sFirst)
        Set srg = .Resize(Rows.Count - .Row + 1)
    End With
    
    Dim irg As Range
    Set irg = Intersect(srg,Target)
    
    If Not srg Is Nothing Then
        ConsolidateProducts
    End If

End Sub