合併具有特定列的主表

Question

我需要一個VBA代碼，可以從不同的工作表中選擇公共列並將其粘貼在彙總表中。

例如，考慮在工作簿中使用3張紙。

Sheet1 has column IP,Tag,Host,service 
Sheet2 has column IP,Tag,REASON,source 
Sheet3 has column IP,Tag,protocol,port. 

我需要一個接一個地在彙總表中獲取公共列（IP，標記）。 任何人都可以請幫助我。

注意：公共列不會始終處於相同（A和B單元格範圍），它可能隨報告而變化。

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

下面的代碼行之有效的要求

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 

Answer 2

一個略顯一般的做法可能是以下幾點：

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 

---

如果張名

在上面的代碼的變化不同，則每次必須遍歷所有工作表是最小的，這是完整的代碼

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

試試這個。

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