在“BOM”表中，我有在 Bom 表中重復多次的組件代碼，并且組件代碼前面有不同的“comp qty”。因此，我只想將“源”表中的組件代碼復制一次，并將消耗量與單個組件代碼相加。在“源”表中，只有一個組件代碼，其前面的總和為“comp qty”。源表中沒有重復的組件代碼。 在此處輸入影像描述 這是我的資料。我使用了一個代碼，但問題是范圍是靜態的。我希望該代碼在“BOM”表中運行直到最后一行，并根據它們的消耗總和復制“源”表中的組件代碼。另一件事是“BOM”表中有多個列，因此這也復制了我的源檔案中的所有列。所以我想要“源”中的兩列，它們是組件代碼和comp qty 我使用的代碼是針對靜態范圍運行的。我想跑到最后一張 bom 表。請指導我。先感謝您。
私有子合并資料（）
Dim this As Variant
Dim that(3000, 1) As String
Dim rowC As Long
Dim colC As Long
this = ThisWorkbook.Sheets("BOM").UsedRange
rowC = ThisWorkbook.Sheets("BOM").UsedRange.Rows.Count
colC = ThisWorkbook.Sheets("BOM").UsedRange.Columns.Count
Dim thisname As String
Dim i As Long
Dim y As Long
Dim x As Long
For i = LBound(this, 1) To UBound(this, 1)
thisname = this(i, 1)
For x = LBound(that, 1) To UBound(that, 1)
If thisname = that(x, 0) Then
Exit For
ElseIf thisname <> that(x, 0) And that(x, 0) = vbNullString Then
that(x, 0) = thisname
Exit For
End If
Next x
Next i
For i = LBound(that, 1) To UBound(that, 1)
thisname = that(i, 0)
For j = LBound(this, 1) To UBound(this, 1)
If this(j, 1) = thisname Then
thisvalue = thisvalue this(j, 2)
End If
Next j
that(i, 1) = thisvalue
thisvalue = 0
Next i
ThisWorkbook.Sheets("Source").range(ThisWorkbook.Sheets("Source").Cells(1, 1), ThisWorkbook.Sheets("Source").Cells(rowC, colC)).Value2 = that
結束子
uj5u.com熱心網友回復：
使用字典的獨特總結
- 為簡化起見，假設范圍至少有兩行，并且值列的單元格是數字。
Option Explicit
Sub ConsolidateData()
' Source
Const sName As String = "BOM"
Const suCol As Long = 1 ' Unique Column Index
Const svCol As Long = 4 ' Value Column Index
' Destination
Const dName As String = "Source"
Const dFirstCellAddress As String = "A1"
' Both
Dim wb As Workbook: Set wb = ThisWorkbook
' Write the values from the source range to an array.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim Data As Variant: Data = srg.Value
' Use a dictionary to keep track of when to write to columns
' and when to just sum up.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
'dict.CompareMode = vbTextCompare
' Write headers.
Data(1, 1) = Data(1, suCol)
Data(1, 2) = Data(1, svCol)
Dim dr As Long: dr = 1 ' new destination row (skip headers)
Dim sKey As Variant ' current value in source unique column
Dim sr As Long ' current source row
Dim dcr As Long ' destination row when summing up
For sr = 2 To UBound(Data, 1) ' skip headers
sKey = Data(sr, suCol)
If Not IsError(sKey) Then ' exclude error values
If Len(sKey) > 0 Then ' exclude blanks
If dict.Exists(sKey) Then ' already in dictionary
dcr = dict(sKey) ' read the 'item' i.e. the destination row
' Only sum up.
Data(dcr, 2) = Data(dcr, 2) Data(sr, svCol)
Else
dr = dr 1 ' new destination row
' Write the new unique value and new destination row
' to the 'key' and 'item' respectively.
dict(sKey) = dr
' Write the values from the two columns to the first columns
' of the destination row.
Data(dr, 1) = Data(sr, suCol)
Data(dr, 2) = Data(sr, svCol)
End If
End If
End If
Next sr
' Write the modified values from the array to the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress)
' Clear previous data.
.Resize(dws.Rows.Count - .Row 1, dws.Columns.Count - .Column 1) _
.Clear
' Write new data.
.Resize(dr, 2).Value = Data
End With
'wb.Save
' Inform.
MsgBox "Data consolidated.", vbInformation
End Sub
編輯
Option Explicit
Sub ConsolidateDataMoreColumns()
' Source
Const sName As String = "BOM"
Const suCol As Long = 1 ' Unique Column Index
Const svCol As Long = 2 ' Value Column Index
Dim soCols As Variant: soCols = VBA.Array(3) ' Other Column Indexes
' To add more columns, use e.g. soCols = VBA.Array(3, 4)
' Destination
Const dName As String = "Source"
Const dFirstCellAddress As String = "A1"
' Both
Dim wb As Workbook: Set wb = ThisWorkbook
' Write the values from the source range to an array.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim Data As Variant: Data = srg.Value
' Use a dictionary to keep track of when to write to columns
' and when to just sum up.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
'dict.CompareMode = vbTextCompare
Dim soUpper As Long: soUpper = UBound(soCols)
Dim so As Long
' Write headers.
Data(1, 1) = Data(1, suCol)
Data(1, 2) = Data(1, svCol)
For so = 0 To soUpper
Data(1, so 3) = Data(1, soCols(so))
Next so
Dim dr As Long: dr = 1 ' new destination row (skip headers)
Dim sKey As Variant ' current value in source unique column
Dim sr As Long ' current source row
Dim dcr As Long ' destination row when summing up
For sr = 2 To UBound(Data, 1) ' skip headers
sKey = Data(sr, suCol)
If Not IsError(sKey) Then ' exclude error values
If Len(sKey) > 0 Then ' exclude blanks
If dict.Exists(sKey) Then ' already in dictionary
dcr = dict(sKey) ' read the 'item' i.e. the destination row
' Only sum up.
Data(dcr, 2) = Data(dcr, 2) Data(sr, svCol)
Else
dr = dr 1 ' new destination row
' Write the new unique value and new destination row
' to the 'key' and 'item' respectively.
dict(sKey) = dr
' Write the values from the columns to the first columns
' of the destination row.
Data(dr, 1) = Data(sr, suCol)
Data(dr, 2) = Data(sr, svCol)
For so = 0 To soUpper
Data(dr, so 3) = Data(sr, soCols(so))
Next so
End If
End If
End If
Next sr
' Write the modified values from the array to the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress)
' Clear previous data.
.Resize(dws.Rows.Count - .Row 1, dws.Columns.Count - .Column 1) _
.Clear
' Write new data.
.Resize(dr, soUpper 3).Value = Data
End With
'wb.Save
' Inform.
MsgBox "Data consolidated.", vbInformation
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qianduan/492540.html
上一篇：如何使用application.worksheetfunction將非常長的公式結果放入單元格中
下一篇：回圈瀏覽作業簿中的所有作業表