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，Tag）。任何人都可以帮我这个。

注意：Common列不会总是在同一个（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

一种通用的方法可能如下：

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 2

试试这个。

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 3

以下代码适用于要求

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

使用特定列合并主表单

3 个答案: