从单独的图纸合并动态命名范围

Question

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

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

例如：工作表1列出了两种产品(B2:B3(，C栏和D栏中有相关的收入和成本数字。工作表2列出了三种产品(B2：B4(，其中。。。我希望工作表3自动更新为(B2:B6(，C列和d列使用原始2个工作表中的数据。这些数据将增长并定期更改。

Answer 1

这里有一种模拟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,rowindex,colindex),
INDEX(data2,rowindex-rows1,colindex))
)

Answer 2

我知道我的代码可能效率非常低——我还处于学习的初期。。。既然我搞不清楚这一点"联合"；事情，我最终运行了以下代码：

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).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, 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).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, startCell.Column).Column

ws3.Range("MiscItem").Copy ws.Cells(lastRow + 1, lastCol)
ws3.Range("Misc").Copy ws.Cells(lastRow + 1, lastCol + 1)

lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, startCell.Column).Column

ws4.Range("WineItem").Copy ws.Cells(lastRow + 1, lastCol)
ws4.Range("Wine").Copy ws.Cells(lastRow + 1, lastCol + 1)

lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, 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).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, startCell.Column).Column

ws.Range(startCell, ws.Cells(lastRow, lastCol)).Select
ThisWorkbook.Names.Add Name:="ConsItem", RefersTo:=Selection
lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, startCell.Column).End(xlToRight).Column

ws.Range(ws.Cells(startCell.Row, startCell.Column + 1), ws.Cells(lastRow, lastCol)).Select
ThisWorkbook.Names.Add Name:="Cons", RefersTo:=Selection
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

结束子

Answer 3

合并工作表

• 将以下内容复制到标准模块中，例如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