Copy data from one WS to another & add 3 new columns based on first worksheet

Question

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!

user_12704593 · Answer

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

Copy data from one WS to another & add 3 new columns based on first worksheet

1 Answers