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.
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
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
No comments:
Post a Comment
Hi User, Thank You for visiting My Blog. Please post your genuine Feedback or comments only related to this Blog Posts. Please do not post any Spam comments or Advertising kind of comments which will be Ignored.