I have two worksheets: one named (raw_data) and the other one named (stock_check). The file has around 200k~ lines in the sheet named raw_data.
The raw_data looks like the following (only added the columns that matter for this case).
On my first sheet raw_data I have roughly 50 columns, out of which I am trying to copy two columns based on the header ID to the sheet stock_check and remove the duplicates. For this I am using the following piece of code:
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
Calling the following function to find the specific headers in the sheet 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
Out of which I am then removing the duplicates using the following the RemoveDuplicates function in VBA.
Sub RemoveDuplicates()
With ThisWorkbook.Worksheets("stock_check")
.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End With
End Sub
Up to here it all works fine, and it generates the following output in Excel (one unique line in Excel):
This is the part where I am stuck/don't know how to continue. What I want to do next is create an available_size column (next to ShopTo_ID) that adds all the available sizes from the raw_data for that particular sales_ID together and separates them by a ",". See below of my expected outcome:
As a next step, I then want to check if the core_size is available, for which I have the following ruleset:
- if available_size includes sizes 8 and 9, then "YES", otherwise "NO"
Which should generate the following output:
As a last step I then want to add a column named stock_depth, based on the number of "," that will check for category X/Y if there is enough stock depth based on the ruleset:
- if available_size is equal or more than 4 and category is X then "YES", otherwise "NO"
- if available_size is equal or more than 2 and category is Y then "YES", otherwise "NO"
Which should generate the following:
Could anyone be so kind to provide me a few pointers of how to continue? Thanks a lot!
CodePudding user response：
Dictionary for unique IDs, Collections for the sizes.
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