Consolidate Master sheet with specific columns - vba

Question

I need a VBA code that can select common columns from different worksheet and paste the same in the summary sheet.
For example, consider am having 3 sheets in a work book.
Sheet1 has column IP,Tag,Host,service
Sheet2 has column IP,Tag,REASON,source
Sheet3 has column IP,Tag,protocol,port.
I need to fetch the common columns(IP,Tag) in a summary sheet one after another.
Can anyone please help me on this.
Note: The Common columns will not be always in the same (A and B cell range) it may vary as of reports.
Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim cell As Range
Dim iLoop As Long, jLoop As Long
jLoop = 2
' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
If myInSht.Name = "PrjA" Or myInSht.Name = "PrjB" Or myInSht.Name = "PrjC" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Consolidated").Range("A:A")
If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Consolidated").Range("B:B")
If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Consolidated").Range("C:C")
If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Consolidated").Range("D:D")
If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Consolidated").Range("E:E")
If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count - 1, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht

Answer 1

Try this.
Sub Consolidate()
Dim FindCol As String
L1 = Sheets(1).Range("XFD2").End(xlToLeft).Column
FindCol = InputBox("Type in header of Column to be searched")
For k = 2 To Sheets.Count
Sheets(k).Select
l = Range("XFD1").End(xlToLeft).Column
For i = 1 To l
x = Range("A65536").End(xlUp).Row
If Cells(1, i).Value = FindCol Then
Range(Cells(1, i), Cells(x, i)).Copy
Sheets(1).Activate
L2 = Range("XFD1").End(xlToLeft).Column
Sheets(1).Cells(1, L2 + 1).Select
ActiveSheet.Paste
End If
Next
Next
Sheets(1).Activate
End Sub

Answer 2

a somewhat general approach could be the following:
Option Explicit
Sub Collect()
Dim sheetsNames As Variant, sharedColumns As Variant
Dim sheetName As Variant, sharedColumn As Variant
Dim summarySheet As Worksheet
sheetsNames = Array("PrjA", "PrjB", "PrjC") '<--| list your sheets names
If FindSharedColumns(sheetsNames, sharedColumns) Then '<--| if any shared columns between ALL listed sheets
Set summarySheet = GetOrCreateSheet("Consolidated") '<--| set or create "Consolidated" sheet: if already there it'll be cleared
With summarySheet
.Range("A1").Resize(, UBound(sharedColumns) + 1).Value = sharedColumns '<--| write headers as the names found in first cell of "shared" columns
End With
For Each sheetName In sheetsNames '<--| loop through sheets ALL sharing the same columns
With Worksheets(sheetName) '<--| reference current sheet in loop
For Each sharedColumn In sharedColumns '<--| loop through shared columns names
With .Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).EntireColumn '<--| reference column corresponding to current shared column in current sheet
With .Resize(WorksheetFunction.CountA(.cells) - 1).Offset(1) '<--| reference its cells from row 2 down to last not empty one (WARNING: it's assumed there are not blank cells in between)
summarySheet.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).End(xlDown).End(xlDown).End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value '<--| update 'summarySheet' appending current values at the bottom of its corresponding column
End With
End With
Next
End With
Next
End If
End Sub
Function GetOrCreateSheet(shtName As String) As Worksheet
If Not GetSheet(shtName, GetOrCreateSheet) Then
Set GetOrCreateSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
GetOrCreateSheet.Name = shtName
Else
GetOrCreateSheet.UsedRange.ClearContents
End If
End Function
Function GetSheet(sheetName As Variant, sht As Worksheet) As Boolean
On Error Resume Next
Set sht = Worksheets(sheetName)
GetSheet = Not sht Is Nothing
End Function
Function FindSharedColumns(sheetsNames As Variant, sharedColumns As Variant) As Boolean
Dim sheetName As Variant
Dim sht As Worksheet
Dim col As Range
Dim key As Variant
With CreateObject("Scripting.Dictionary")
For Each sheetName In sheetsNames
If GetSheet(sheetName, sht) Then
For Each col In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(col.Value) = .Item(col.Value) + 1
Next
End If
Next
For Each key In .keys
If .Item(key) < UBound(sheetsNames) + 1 Then .Remove key
Next
If .Count > 0 Then
sharedColumns = .keys
FindSharedColumns = True
End If
End With
End Function
if sheets names differs every time then you have to loop through all worksheets
the changes in the above code are minimal, here's the complete code
Option Explicit
Sub Collect()
Dim sheetsNames As Variant, sharedColumns As Variant
Dim sht As Worksheet, sharedColumn As Variant
Dim summarySheet As Worksheet
If FindSharedColumns(sharedColumns) Then '<--| if any shared columns between ALL worksheets
Set summarySheet = GetOrCreateSheet("Consolidated") '<--| set or create "Consolidated" sheet: if already there it'll be cleared
With summarySheet
.Range("A1").Resize(, UBound(sharedColumns) + 1).Value = sharedColumns '<--| write headers as the names found in first cell of "shared" columns
End With
For Each sht In Worksheets '<--| loop through all worksheets
With sht '<--| reference current sheet in loop
For Each sharedColumn In sharedColumns '<--| loop through shared columns names
With .Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).EntireColumn '<--| reference column corresponding to current shared column in current sheet
With .Resize(WorksheetFunction.CountA(.cells) - 1).Offset(1) '<--| reference its cells from row 2 down to last not empty one (WARNING: it's assumed there are not blank cells in between)
summarySheet.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).End(xlDown).End(xlDown).End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value '<--| update 'summarySheet' appending current values at the bottom of its corresponding column
End With
End With
Next
End With
Next
End If
End Sub
Function GetOrCreateSheet(shtName As String) As Worksheet
If Not GetSheet(shtName, GetOrCreateSheet) Then
Set GetOrCreateSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
GetOrCreateSheet.Name = shtName
Else
GetOrCreateSheet.UsedRange.ClearContents
End If
End Function
Function GetSheet(sheetName As Variant, sht As Worksheet) As Boolean
On Error Resume Next
Set sht = Worksheets(sheetName)
GetSheet = Not sht Is Nothing
End Function
Function FindSharedColumns(sharedColumns As Variant) As Boolean
Dim sheetName As Variant
Dim sht As Worksheet
Dim col As Range
Dim key As Variant
With CreateObject("Scripting.Dictionary")
For Each sht In Worksheets
For Each col In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(col.Value) = .Item(col.Value) + 1
Next
Next
For Each key In .keys
If .Item(key) < Worksheets.Count Then .Remove key
Next
If .Count > 0 Then
sharedColumns = .keys
FindSharedColumns = True
End If
End With
End Function

Answer 3

The below code works well the requirement
Sub Collect()
Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim calcState As Long
Dim scrUpdateState As Long
Dim cell As Range
Dim iLoop As Long, jLoop As Long
jLoop = 2
' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
'If myInSht.Name = "a" Or myInSht.Name = "aa" Or myInSht.Name = "aaa" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "timestamp" Then Set myOutCol = Sheets("Summary").Range("B2:B1000")
If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Summary").Range("C2:C1000")
If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Summary").Range("D2:D1000")
If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Summary").Range("E2:E1000")
If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Summary").Range("F2:F1000")
If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Summary").Range("G2:G1000")
If aCol.Cells(1, 1).Value = "asn" Then Set myOutCol = Sheets("Summary").Range("I2:I1000")
If aCol.Cells(1, 1).Value = "geo" Then Set myOutCol = Sheets("Summary").Range("J2:J1000")
If aCol.Cells(1, 1).Value = "region" Then Set myOutCol = Sheets("Summary").Range("K2:K1000")
If aCol.Cells(1, 1).Value = "naics" Then Set myOutCol = Sheets("Summary").Range("L2:L1000")
If aCol.Cells(1, 1).Value = "sic" Then Set myOutCol = Sheets("Summary").Range("M2:M1000")
If aCol.Cells(1, 1).Value = "server_name" Then Set myOutCol = Sheets("Summary").Range("H2:H1000")
If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
'End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht
End Sub