Thursday, 27 October 2016

VBA Macro to Consolidate Specific Columns from Multiple Sheets into One Column of Target Sheet and Remove Duplicates

How to Consolidate Specific Columns from Multiple Sheets into One Sheet in One Column and Remove Duplicates with Excel VBA
The following Macro Consolidates the Specific Fields(Sales Regions) from two Sheets "Data" and "Data_Cloud" into the Sheet "Hierarchy" in One Column(say B2), the assigning then Tags(SR1,SR2...) in Column A, then Removes the Duplicates.
Sub Consol_Hierarchy()

Dim WS As Worksheet
Dim TGT_WS As Worksheet
Dim LV As String

Set TGT_WS = Sheets("Hierarchy")
RC = TGT_WS.Cells(Rows.Count, "A").End(xlUp).Row
TGT_WS.Range("A2", Cells(2, 1).Offset(RC - 1, 1)).Clear

For Y = 1 To 2

If Y = 1 Then
    Set WS = Sheets("Data")
 Else
    Set WS = Sheets("Data_Cloud")
End If

'CC = WS.Cells(1, Columns.Count).End(xlToLeft).Column
'RC = WS.Cells(Rows.Count, "A").End(xlUp).Row

For K = 1 To 6

    Select Case K
    Case 1
            SR = "Sales Region1"
            LV = "SR_1"
    Case 2
            SR = "Sales Region 2"
            LV = "SR_2"
    Case 3
            SR = "Sales Region 3"
            LV = "SR_3"
    Case 4
            SR = "Sales Region 4"
            LV = "SR_4"
    Case 5
            SR = "Sales Region 5"
            LV = "SR_5"
    Case Else
            SR = "Sales Region 6"
            LV = "SR_6"
    End Select

WS.Activate
For X = 1 To 20
    If WS.Cells(1, X) = SR Then
    
        WS.Cells(1, X).Select
        RC = WS.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
        'Range(Selection, Selection.Offset(RC - 1, 0)).Select
        Range(Selection, Selection.Offset(RC - 1, 0)).Copy
        TGT_WS.Activate
        RC1 = (TGT_WS.Cells(Rows.Count, "A").End(xlUp).Row) + 1
            TGT_WS.Range("B" & RC1).Select
            TGT_WS.Paste
            TGT_WS.Range("A" & RC1).Select
            TGT_WS.Range(Selection, Selection.Offset(RC - 1, 0)).Select
            Selection.Value = LV
        
            TGT_WS.Columns("A:B").Select
            Selection.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
            TGT_WS.Range("A1").Select
            Exit For
    End If

Next X

Next K
Next Y

Set WS = Nothing
Set TGT_WS = Nothing
 MsgBox "All the SR Nodes Consolidated from Data and Data_Cloud Tabs", vbOKOnly, "Nodes Consolidated Succesfully"

End Sub

Thanks,
TAMATAM

Follow Me by Email

ExcelKingdom-Popular Posts

ExcelKingdom-Random Posts