VBA Duplicates

[StevenTG]

Hello,

I am writing a VBA code but I am getting stuck. Essentially with this code, i am selecting a file and the macro is re-organizing it.

There is one for Company Number, Company Name, Wage(number amount), Social Media Page(X,Insta,Facebook, etc.).

There are multiple lines of the same company number and name, but with a different social media page.

Essentially, I want, if there are multiple lines of the same company but with a different social media page, to half whatever is in the wage column, but if there is just one company with just a single line, then do not half whatever is in the wage, just leave it be.


This is the code where it declares what each cell value is, and then if there is a company number, then print each in each cell

If ActiveCell.Value <> "" Then
coNum = ActiveCell.Value
co = ActiveCell.Offset(0, 1).Value
wage = ActiveCell.Offset(0, 2).Value
socialMedia = ActiveCell.Offset(0, 3).Value



Worksheets("Test_File").Select
Worksheets("Test_File").Range("A65536").End(xlUp).Select

If workRow2 = 0 Then
workRow2 = ActiveCell.Row
End If

Worksheets("Test_File").Range("a" & workRow2).Select

If coNum <> "" Then
ActiveCell.Value = coNum
ActiveCell.Offset(0, 1).Value = co
ActiveCell.Offset(0, 2).Value = wage
ActiveCell.Offset(0, 3).Value = wage / 2
ActiveCell.Offset(0, 4).Value = socialMedia
nextRow = 1
workRow2 = workRow2 + 1





But with this, it is going to half the wage for every thing. Even the companies that only have one line.

 

[Alex Blakenburg]

I am unclear on whether you want the output on a different sheet or not. The fact that you have added a column being Wage / 2 makes me think you do.
So lets start with this, it assumes you have an output sheet and that you have changed the sheet names in the code to you input and output sheet names.

Source Data:

20231229 VBA Dic StevenTG.xlsm
	A	B	C	D
1	Company Number	Company Name	Wage	Social Media Page
2	1	Coy 1	100	X
3	1	Coy 1	100	Insta
4	1	Coy 1	100	Facebook
5	2	Coy 2	500	X
6	3	Coy 3	4000	Insta
7	3	Coy 3	4000	Facebook
Source

Output:

20231229 VBA Dic StevenTG.xlsm
	A	B	C	D	E
1	Company Number	Company Name	Wage	Wage / 2	Social Media Page
2	1	Coy 1	100	50	X
3	1	Coy 1	100	50	Insta
4	1	Coy 1	100	50	Facebook
5	2	Coy 2	500		X
6	3	Coy 3	4000	2000	Insta
7	3	Coy 3	4000	2000	Facebook
Test_File

Code:

    Dim srcWS As Worksheet, destWS As Worksheet
    Dim srcRng As Range, srcArr As Variant
    Dim destArr As Variant, destHdg As Variant
    Dim srcRowLast As Long, destRowNext As Long
    Dim i As Long, j As Long
   
    Set srcWS = Worksheets("Source")                ' <--- Change Sheet name to your sheet name
    Set destWS = Worksheets("Test_File")            ' <--- Change Sheet name to your sheet name
   
    With srcWS
        srcRowLast = .Range("A" & Rows.Count).End(xlUp).Row
        Set srcRng = .Range("A2:D" & srcRowLast)
        srcArr = srcRng.Value
    End With
   
    With destWS
        If .Range("A1") = "" Then
            destHdg = Array("Company Number", "Company Name", "Wage", "Wage / 2", "Social Media Page")
            .Range("A1").Resize(, UBound(destHdg) + 1).Value = destHdg
        End If
        destRowNext = destWS.Range("A" & Rows.Count).End(xlUp).Row + 1
    End With
   
    ReDim destArr(1 To UBound(srcArr), 1 To UBound(srcArr, 2) + 1)
   
    Dim dictCoy As Object, dictKey As String

    Set dictCoy = CreateObject("Scripting.dictionary")
    dictCoy.CompareMode = vbTextCompare
   
    ' Load details range into Dictionary and load output array
    For i = 1 To UBound(srcArr)
        For j = 1 To 3
            destArr(i, j) = srcArr(i, j)
        Next j
        destArr(i, 5) = srcArr(i, 4)
             
        dictKey = srcArr(i, 1)
        If Not dictCoy.exists(dictKey) Then
            dictCoy(dictKey) = i
        Else
            destArr(i, 4) = srcArr(i, 3) / 2
            If dictCoy(dictKey) <> 0 Then
                ' first time duplicate detected change 1st occurence to wage / 2
                destArr(dictCoy(dictKey), 4) = srcArr(dictCoy(dictKey), 3) / 2
                dictCoy(dictKey) = 0
            End If
        End If
    Next i

    ' Write back Rpt updated data
    destWS.Range("A" & destRowNext).Resize(UBound(destArr), UBound(destArr, 2)).Value = destArr


End Sub