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]

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.

3rd row in 14th sheet? or 3rd row in all the other sheets are headings?

 

[Haree]

sorry wasn't clear in explaining.
all the other sheets have headings in the first row
the 14th sheet alone has headings for the first two rows

 

[snjpverma]

Try this in a copy of your workbook as after running the Macro you won't get Undo option and I am a beginner in VBA.

I have assumed that there are no extra sheets in your sheets apart from these 14.
The code consolidates names from all the sheets in the workbook and pastes it in Sheet "N".

Sub UniqueNames()

Dim lrow As Integer

Dim sht As Worksheet
Application.ScreenUpdating = False
    For Each sht In ThisWorkbook.Sheets
        If sht.Name <> "N" Then
             sht.Range("D2", sht.Range("D" & Rows.Count).End(xlUp)).Copy
                If Sheets("N").Range("K" & Rows.Count).End(xlUp).Offset(1).Row < 4 Then
                    Sheets("N").Range("K3").PasteSpecial xlPasteValues
                    Else
                    Sheets("N").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("N").Range("K" & Rows.Count).End(xlUp).Offset(1).Row < 4 Then
                            Sheets("N").Range("K3").PasteSpecial xlPasteValues
                            Else
                            Sheets("N").Range("K" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                        End If
        End If
    Next
Application.CutCopyMode = False
lrow = Sheets("N").Range("K" & Rows.Count).End(xlUp).Row

Sheets("N").Range("L3", "L" & lrow).Formula = "=SUM((SUMIF($B$1:$D$1300,K3,$D$1:$D$1300))-(SUMIF($F$1:$H$1300,K3,$H$1:$H$1300)))"
Application.ScreenUpdating = True
End Sub

 

[snjpverma]

Use this instead as I forgot to remove duplicates in the previous code. Try it in a copy of your workbook as after running the Macro you won't get Undo option and I am a beginner in VBA.

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

Application.ScreenUpdating = False
    For Each sht In ThisWorkbook.Sheets
        If sht.Name <> "N" Then
             sht.Range("D2", sht.Range("D" & Rows.Count).End(xlUp)).Copy
                If Sheets("N").Range("K" & Rows.Count).End(xlUp).Offset(1).Row < 4 Then
                    Sheets("N").Range("K3").PasteSpecial xlPasteValues
                    Else
                    Sheets("N").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("N").Range("K" & Rows.Count).End(xlUp).Offset(1).Row < 4 Then
                            Sheets("N").Range("K3").PasteSpecial xlPasteValues
                            Else
                            Sheets("N").Range("K" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                        End If
        End If
    Next
Application.CutCopyMode = False
Sheets("N").Range("K2", Sheets("N").Range("K3").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes

lrow = Sheets("N").Range("K" & Rows.Count).End(xlUp).Row
Sheets("N").Range("L3", "L" & lrow).Formula = "=SUM((SUMIF($B$1:$D$1300,K3,$D$1:$D$1300))-(SUMIF($F$1:$H$1300,K3,$H$1:$H$1300)))"
Application.ScreenUpdating = True
End Sub

 

[MoshiM]

Sub Collect_and_Remove_Duplicates()

Dim WS As Worksheet, Name_CLCTN As New Collection, Output() As Variant, Y As Long, STR As String, _
WSD() As Variant, B As Long, Array_Column As Long

For Each WS In ThisWorkbook.Worksheets

    With WS

      If .Name Like "[A-M,a-m]" Then
  
          For Y = 0 To 1
              STR = Array("D", "J")(Y)
          
              Array_Column = IIf(STR = "D", .Columns("D").Column, .Columns("J").Column)
          
              With .UsedRange 'Used if unused columns before D or J
                  Array_Column = Array_Column - .Column + 1
                  WSD = .Columns(Array_Column).Value
              End With
          
              On Error Resume Next
          
              For B = LBound(WSD, 1) + 1 To UBound(WSD, 1)'Adds only unique values to collection
                  If Not IsEmpty(WSD(B, 1)) Then Name_CLCTN.Add WSD(B, 1), lcase(WSD(B, 1))'LCase version used as key in Collection
              Next B
             
              On Error GoTo 0

          Next Y
      
      End If

    End With

Next WS

On Error GoTo 0

With Name_CLCTN

    ReDim Output(1 To .Count, 1 To 1)
    For Y = 1 To .Count
        Output(Y, 1) = .ITEM(Y)
    Next Y

End With

With ThisWorkbook.Worksheets("N").Range("K3").Resize(UBound(Output, 1))
    .Value = Output
    .Offset(, 1).Formula = "=SUM((SUMIF($B$1:$D$1300,K3,$D$1:$D$1300))-(SUMIF($F$1:$H$1300,K3,$H$1:$H$1300)))"
End With

End Sub

 

[Haree]

@
snjpverma

i tried your code it works thank you so much, i just have a small change, it brings in all the rows of the column D and J i have blank rows as well. for example D1: D100 doesnt have to have 100 names it will have approximately 78 names with blanks in between

 

[Haree]

@
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)

 

[snjpverma]

Try this in a copy of your workbook as after running the Macro you won't get Undo option and I am a beginner in VBA.

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

Application.ScreenUpdating = False
    For Each sht In ThisWorkbook.Sheets
        If sht.Name <> "N" Then
             sht.Range("D2", sht.Range("D" & Rows.Count).End(xlUp)).Copy
                If Sheets("N").Range("K" & Rows.Count).End(xlUp).Offset(1).Row < 4 Then
                    Sheets("N").Range("K3").PasteSpecial xlPasteValues
                    Else
                    Sheets("N").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("N").Range("K" & Rows.Count).End(xlUp).Offset(1).Row < 4 Then
                            Sheets("N").Range("K3").PasteSpecial xlPasteValues
                            Else
                            Sheets("N").Range("K" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                        End If
        End If
    Next
Application.CutCopyMode = False

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

Proceed:
lrow = Sheets("N").Range("K" & Rows.Count).End(xlUp).Row
Sheets("N").Range("L3", "L" & lrow).Formula = "=SUM((SUMIF($B$1:$D$1300,K3,$D$1:$D$1300))-(SUMIF($F$1:$H$1300,K3,$H$1:$H$1300)))"
Application.ScreenUpdating = True
End Sub

 

[Haree]

Hello
Thank you so much sir. it worked like a charm
i have assigned it to a command button and i want it to get updated every time i click it so i added these two lines


Dim lrow As Integer
Dim sht As Worksheet
Dim rng As Range

Application.ScreenUpdating = False
ActiveSheet.Range("K:L").Select
Selection.ClearContents
For Each sht In ThisWorkbook.Sheets

but it is deleting my heading in column k and l so i changed it to
ActiveSheet.Range("K3:L500").Select
Selection.ClearContents

when i do this i get a error in the following line
rng.Rows.Delete Shift:=xlShiftUp.