我有两张工作表:一张名为 (raw_data),另一张名为 (stock_check)。该文件在名为 raw_data 的工作表中有大约 200k~ 行。
raw_data 如下所示(仅添加了对这种情况重要的列)。
在我的第一张工作表 raw_data 上,我大约有 50 多列,其中我试图根据标题 ID 将两列复制到工作表 stock_check 并删除重复项。为此,我使用以下代码:
Sub CopyMultipleColumns()
Dim wb As Workbook
Dim newSht As Worksheet, Hdrs As Variant, i As Long, EdrisRange As Range
Hdrs = Array("Sales_ID", "Category", "ShopTo_ID")
Set wb = ThisWorkbook
Set newSht = ThisWorkbook.Worksheets("stock_check")
For i = LBound(Hdrs) To UBound(Hdrs)
Set EdrisRange = FindHeaderInWorkbook(wb, CStr(Hdrs(i)), newSht)
If Not EdrisRange Is Nothing Then
Application.Intersect(EdrisRange.EntireColumn, EdrisRange.Parent.UsedRange).Copy _
newSht.Cells(1, i + 1).PasteSpecial xlPasteValues
End If
Next i
Application.CutCopyMode = False
End Sub
调用以下函数查找工作表 raw_data 中的特定标题Function FindHeaderInWorkbook(wb As Workbook, HeaderText As String, excludeSheet As
Worksheet)
Dim sht As Worksheet, rng As Range
For Each sht In wb.Worksheets
If sht.Name <> excludeSheet.Name Then
Set rng = sht.Rows(1).Find(what:=HeaderText, lookat:=xlWhole)
If Not rng Is Nothing Then Exit For
End If
Next sht
Set FindHeaderInWorkbook = rng
End Function
然后,我将使用以下 VBA 中的 RemoveDuplicates 函数删除其中的重复项。Sub RemoveDuplicates()
With ThisWorkbook.Worksheets("stock_check")
.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End With
End Sub
到目前为止,一切正常,它在 Excel 中生成以下输出(Excel 中的一个唯一行):这是我被卡住/不知道如何继续的部分。我接下来要做的是创建一个 available_size 列(在 ShopTo_ID 旁边),它将 raw_data 中该特定 sales_ID 的所有可用尺寸加在一起,并用“,”分隔它们。请参阅下面的我的预期结果:
下一步,我想检查 core_size 是否可用,为此我有以下规则集:
这应该生成以下输出:
作为最后一步,我想添加一个名为 stock_depth 的列,基于 ","的数量,如果基于规则集有足够的库存深度,它将检查类别 X/Y:
这应该生成以下内容:
谁能给我一些关于如何继续的指示?非常感谢!
最佳答案
唯一 ID 的字典,大小的集合。
Option Explicit
Sub StockCheck()
Const SEP = "~"
Dim wb As Workbook, ws As Worksheet, wsData As Worksheet
Dim a, Hdrs, HCol, data
Dim hasChkSht As Boolean, hasData As Boolean
Dim lastrow As Long, i As Long, x As Long
Dim t0 As Single: t0 = Timer
Hdrs = Array("Sales_ID", "Category", "ShopTo_ID", "SizeDescription")
ReDim data(UBound(Hdrs)) As Variant
' find data sheets
Set wb = ThisWorkbook
For Each ws In wb.Sheets
If ws.Name = "stock_check" Then
hasChkSht = True
Else
a = Application.Match(Hdrs(0), ws.Rows(1), 0)
If Not IsError(a) Then
hasData = True
Set wsData = ws
Exit For
End If
End If
Next
If hasData = False Then
MsgBox "Could not locate Header " & Hdrs(0), vbCritical
Exit Sub
End If
' copy data into arrays
Dim ar
With wsData
lastrow = .Cells(.Rows.Count, a).End(xlUp).Row
' find columns
For i = 0 To UBound(Hdrs)
a = Application.Match(Hdrs(i), wsData.Rows(1), 0)
If IsError(a) Then
MsgBox "Could not locate Header " & Hdrs(i), vbCritical
Exit Sub
Else
ar = data(i)
ReDim ar(1 To lastrow - 1, 1 To 1)
data(i) = wsData.Cells(2, a).Resize(lastrow - 1).Value2
End If
Next
End With
' collate data
Dim dict As Object, k, hasSize As Boolean
Dim s As String, sz As String, n As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(data(0))
k = data(0)(i, 1) & SEP & data(1)(i, 1) & SEP & data(2)(i, 1)
sz = data(3)(i, 1)
'Debug.Print "Row", i, k, sz
If Not dict.exists(k) Then
dict.Add k, New Collection
dict(k).Add sz
'Debug.Print k, dict(k)(1)
Else
' check size collection
hasSize = False
For n = 1 To dict(k).Count
'Debug.Print n, dict(k)(n), sz
If dict(k)(n) = sz Then
hasSize = True
Exit For
End If
Next
' add if required
If hasSize = False Then
dict(k).Add sz
'Debug.Print k, sz
End If
End If
Next
' output
i = 2
Application.ScreenUpdating = False
With wb.Sheets("stock_check")
.Cells.Clear
.Range("A1:F1") = Array("Sales_ID", "Category", "ShopTo_ID", "sizes_available", _
"core size?", "stock_depth")
For Each k In dict
ar = Split(k, SEP)
.Cells(i, 1) = ar(0)
.Cells(i, 2) = ar(1)
.Cells(i, 3) = ar(2)
.Cells(i, 5) = "NO"
' sizes
s = ""
For n = 1 To dict(k).Count
sz = dict(k).Item(n)
If n > 1 Then s = s & ","
s = s & sz
' core ?
If sz = 8 Or sz = 9 Then
.Cells(i, 5) = "YES"
End If
Next
.Cells(i, 4) = s
' stock
If ar(1) = "X" And dict(k).Count >= 4 Then
s = "YES"
ElseIf ar(1) = "Y" And dict(k).Count >= 2 Then
s = "YES"
Else
s = "NO"
End If
.Cells(i, 6) = s
i = i + 1
Next
.Activate
.Range("A1").Select
End With
Application.ScreenUpdating = True
MsgBox lastrow - 1 & " rows processed", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
关于excel - 将数据从一个 AWS 复制到另一个 AWS,并根据第一个工作表添加 3 个新列,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/71089745/