Get Names and remove duplicates

[Haree]

Hello
I have 14 sheets say that each sheet is named with letters of the alphabet like A, B , C till N
In all the sheets except the last one i have names in column D and Column J. i want all these names from both columns and all the sheets to be displayed in column K of the 14th sheet (Note it should start from the 3rd row because first two are headings and they are filled already), and i want the duplicates to be removed.

in column L of the 14th sheet i want the following formula for all the names in the K column
the formula is [=SUM((SUMIF($B$1:$D$1300,K3,$D$1:$D$1300))-(SUMIF($F$1:$H$1300,K3,$H$1:$H$1300)))]
assuming there are names in column k from k3 to k100 i want this formula in l3 to l100
thanks in advance.

 

[snjpverma]

Could you tell us what error you get? And also if you can provide the entire code after the changes you made?

Also, are you sure that the contents won't go beyond 500 rows? Because you have used k3:L500. You could use a bigger number on the safer side like 5000 instead of 500.

 

[MoshiM]

@
MoshiM

Sir Thank you so much for your code, i am getting subscript out of range error
and if i debug the error comes in this line

ReDim Output(1 To .Count, 1 To 1)

Looks like no items were added to the collection then. Can you step through the code to see which if any of of the conditional IF statements were executed. I can't reproduce the error on my end. Unless I completely misunderstood the names of your target sheets which should be a single letter in the range of A-N.

 

[Haree]

@snjpverma

Sorry for the late reply, we weren't working due to the ongoing pandemic. I just have a small help. I am attaching the code which i have tweaked from your version.

Sub UniqueNames()
Dim lrow As Integer
Dim sht As Worksheet
Dim rng As Range

Application.ScreenUpdating = False
ActiveSheet.Range("K3:L5000").Select
Selection.ClearContents
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "Total" Or sht.Name <> "Debtors" Or sht.Name <> "Names" Then
sht.Range("D2", sht.Range("D" & Rows.Count).End(xlUp)).Copy
If Sheets("Names").Range("K" & Rows.Count).End(xlUp).Offset(1).Row < 4 Then
Sheets("Names").Range("K3").PasteSpecial xlPasteValues
Else
Sheets("Names").Range("K" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
sht.Range("J2", sht.Range("J" & Rows.Count).End(xlUp)).Copy
If Sheets("Names").Range("K" & Rows.Count).End(xlUp).Offset(1).Row < 4 Then
Sheets("Names").Range("K3").PasteSpecial xlPasteValues
Else
Sheets("Names").Range("K" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
End If
End If
Next
Application.CutCopyMode = False

Sheets("Names").Range("K2", Sheets("Names").Range("K" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlYes
On Error GoTo 0
Set rng = Sheets("Names").Range("k:k").SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
rng.Rows.Delete Shift:=xlShiftUp
Application.ScreenUpdating = True
End Sub



If sht.Name <> "Total" Or sht.Name <> "Debtors" Or sht.Name <> "Names" Then
it isn't omitting these sheets. It brings data from these sheets as well.

Kindly Help me with these please

 

[Yongle]

Try this on a COPY of your workbook

Sub UniqueNames()
'speed up processing
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
'variables
    Const x As Long = 5000
    Dim r As Long, sht As Worksheet, ws As Worksheet, rng As Range
'clear old values
    Set ws = Sheets("Names"):  r = ws.Cells.Rows.Count
    ws.Range("K3:L3").Resize(x).ClearContents
'insert values
    For Each sht In ThisWorkbook.Sheets
        Select Case sht.Name
            Case "Total", "Debtors", "Names"        'these are ignored
          
            Case Else
                With ws.Range("K" & r)
                    .End(xlUp).Offset(1).Resize(x).Value = sht.Range("D2").Resize(x).Value
                    .End(xlUp).Offset(1).Resize(x).Value = sht.Range("J2").Resize(x).Value
                End With
        End Select
    Next sht
'remove duplicates and blanks
    ws.Range("K2:K" & r).RemoveDuplicates Columns:=1, Header:=xlYes
    On Error GoTo 0
    Set rng = ws.Range("K3:K" & r).SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    rng.Delete Shift:=xlShiftUp
'insert formula and reset
    ws.Range("K3", ws.Range("K" & r).End(xlUp)).Offset(, 1).Formula = "=SUM((SUMIF($B$1:$D$1300,K3,$D$1:$D$1300))-(SUMIF($F$1:$H$1300,K3,$H$1:$H$1300)))"
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[Haree]

Worked so well, Thank You so much for taking out time and helping me.

 

[Yongle]

You are welcome
Just one thing - I just spotted - a minor amendment

    On Error Resume Next
    Set rng = ws.Range("K3:k" & r).SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0