Question

第一组数据是前两列中可能数据的片段（运行到数千行）。

第一列有重复的票号，状态不同。我想为每个票证和相应的列创建一个唯一的行以具有各种状态（像转置一样）。见下图：

Incident Number Measurement Status
INCIN0001910583 Detached
INCIN0001910583 Missed
INCIN0001908104 Detached
INCIN0001908104 Detached
INCIN0001908104 Missed
INCIN0001914487 Met
INCIN0001908444 Detached
INCIN0001908444 Detached
INCIN0001908444 Detached
INCIN0001908444 Met
INCIN0001910624 Met
INCIN0001910575 Detached
INCIN0001910575 Met

我正在寻找一个宏（或公式）来实现这样的目标：

INCIN0001910583 Detached    Missed      
INCIN0001908104 Detached    Detached    Missed  
INCIN0001914487 Met         
INCIN0001908444 Detached    Detached    Detached    Met
INCIN0001910624 Met         
INCIN0001910575 Detached    Met

正如Tom指出的那样，下面是我用来实现这一目的的录制宏，在第一次出现的唯一事件编号（A列）中粘贴转置，然后手动删除空白。（但是需要很长时间才能完成完成数千行）

Sub transpose_paste()
'
' transpose_paste Macro
'
' Keyboard Shortcut: Ctrl+t
'
    Selection.Copy
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 12
    ActiveWindow.ScrollColumn = 11
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 11
    Cells(ActiveCell.Row, 14).Select

    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveWindow.ScrollColumn = 10
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
End Sub

Answer 1

我不确定我明白汤姆为什么会给你他的建议。由于记录代码的非动态特性而不是数据的动态特性，因此获取录制的宏不是一个好主意。

以下是两个选项。第一个是你要求的（运行'PivotData_All'例程），另一个是你想要从后续数据列中排除非唯一项目（运行'PivotData_UniquesOnly'例程）。

Sub PivotData_All()
    With Worksheets("Sheet1")
        Call PivotData(.Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row), False)
    End With
End Sub

Sub PivotData_UniquesOnly()
    With Worksheets("Sheet1")
        Call PivotData(.Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row), True)
    End With
End Sub


Sub PivotData( _
    ByVal IncidentData As Range, _
    Optional ByVal UniquesOnly As Boolean = False _
    )
'
' Take data from a given range and pivot out data based on first column being incident numbers, second column being
' measurement status. Each unique incident will be given its own row and the measurment status will be pivoted out
' along columns on a new sheet.
'
' Syntax:       PivotData(UniquesOnly)
'
' Parameters:   IncidentData. Range. Required. A two-column set of data. Left column is incident number, right column
'               is measurement status.
'               UniquesOnly. Boolean. Optional. Specify whether second column of data should contain only unique values
'               or not. If omitted False is passed.
'
    Dim Incidents As Collection
    Dim NewSheet As Worksheet
    Dim Incident() As Variant
    Dim IncidentItem As Variant
    Dim IncidentTempValues() As Variant
    Dim IncidentStep As Long
    Dim IncidentMatch As Long
    Dim IncidentKey As String

    '// Change these as necessary

    '// Get values into an array to start
    IncidentTempValues = IncidentData.Value

    '// Iterate through array to get unique values, append all measurements to individual array
    Set Incidents = New Collection
    For IncidentStep = LBound(IncidentTempValues, 1) To UBound(IncidentTempValues, 1)

        IncidentKey = CStr(IncidentTempValues(IncidentStep, 1))

        If InCollection(Incidents, IncidentKey) = False Then
            Incident = Array(IncidentKey, IncidentTempValues(IncidentStep, 2))
            Incidents.Add Incident, IncidentKey
        Else
            Erase Incident
            Incident = Incidents.Item(IncidentKey)
            IncidentMatch = 0
            If UniquesOnly Then
                On Error Resume Next
                IncidentMatch = WorksheetFunction.Match(IncidentTempValues(IncidentStep, 2), Incident, 0)
                On Error GoTo 0
            End If
            If IncidentMatch = 0 Then
                ReDim Preserve Incident(LBound(Incident) To UBound(Incident) + 1)
                Incident(UBound(Incident)) = IncidentTempValues(IncidentStep, 2)
                Incidents.Remove IncidentKey
                Incidents.Add Incident, IncidentKey
            End If
        End If

    Next IncidentStep

    '// Put values into new sheet
    If Incidents.Count > 0 Then
        Set NewSheet = Worksheets.Add
        IncidentStep = 1
        For Each IncidentItem In Incidents
            NewSheet.Cells(IncidentStep, 1).Resize(1, UBound(IncidentItem) - LBound(IncidentItem) + 1).Value = IncidentItem
            IncidentStep = IncidentStep + 1
        Next IncidentItem
        NewSheet.Cells.EntireColumn.AutoFit
    End If

    '// Message user upon completion
    If Incidents.Count > 0 Then
        MsgBox "New sheet created ('" & NewSheet.Name & "') with " & Incidents.Count & " record(s).", vbInformation, "Complete"
    Else
        MsgBox "Unable to create incident data.", vbExclamation, "Whoops!"
    End If

End Sub

Public Function InCollection(CheckCollection As Collection, CheckKey As String) As Boolean
'
' Returns True if the specified key is found in the specified collection.
'
' Syntax:       InCollection(CheckCollection,CheckKey)
'
' Parameters:   CheckCollection. Collection. Required. The collection to search in.
'               CheckKey. String. Required. The string key to search in collection for.
'
    On Error Resume Next
    InCollection = CBool(Not IsEmpty(CheckCollection(CheckKey)))
    On Error GoTo 0

End Function

这需要进入标准模块。如果您需要其他帮助，请告诉我们。

此致 Zack Barresse

Answer 2

此过程假设如下：

数据范围从A1开始，包括两列，它是连续的数据范围（即中间没有空行，列C为空

输出数据从D1

开始

Sub Rng_List_Unique_Records()
Dim vSrc As Variant, sKey As String
Dim sStatus As String, aStatus As Variant
Dim lRow As Long, l As Long

    With ThisWorkbook.Sheets(1)
        Application.Goto .Cells(1), 1

        Rem Set Array with Source Range Data
        vSrc = .Cells(1).CurrentRegion.Value2

        Rem Extract Unique Items
        For l = 1 To UBound(vSrc)
            If vSrc(l, 1) = sKey Then
                Rem Same Incident - Add Measurement
                sStatus = sStatus & ";" & vSrc(l, 2)

            Else
                If sStatus <> Empty Then
                    Rem Enter Measurements for Prior Incident
                    aStatus = Split(sStatus, ";")
                    .Cells(lRow, 5).Resize(, 1 + UBound(aStatus)) = aStatus
                End If

                Rem New Incident
                lRow = 1 + lRow
                sKey = vSrc(l, 1)
                .Cells(lRow, 4) = sKey
                sStatus = vSrc(l, 2)

        End If: Next

        Rem Enter Measurements for Last Incident
        aStatus = Split(sStatus, ";")
        .Cells(lRow, 5).Resize(, 1 + UBound(aStatus)) = aStatus

        Rem Output Range Columns AutoFit
        .Cells(4).CurrentRegion.EntireColumn.AutoFit

    End With

End Sub

建议访问以下页面以更深入地了解所使用的资源：

Variables & Constants，Application Object (Excel)，Excel Objects

With Statement，For Each...Next Statement，If...Then...Else Statement

Range Object (Excel)，Worksheet Object (Excel)

尽管如此，请告诉我有关该程序的任何问题

Answer 3

这是一个缓慢的一天所以.....这将使用vba做你想要的。你也可以通过斯科特上面提到的公式或甚至使用数据透视表来实现这一点。然而，通过问题的外观，你正在寻找一些动态的东西，它将自动扩展，以包括公式不易做的新事件。

我对此表示赞赏，希望您能够轻松理解未来的修改。这可能不是唯一的方法，而不一定是最好的。

Option Explicit
Sub transposeAndCombine()
    ' Declare all of the variable names and types we will be using
    Dim inc As Object
    Dim c As Integer: Dim i As Integer
    Dim rng As Range
    Dim f
    Dim ws as worksheet

    ' Turns off screen updating - good practice for the majority of vba macros
    Application.ScreenUpdating = False
    ' Declare worksheet
    set ws = ThisWorkbook.Sheets("Sheet1")
    ' Change Sheet1 to relevant sheet
    ' You'll also need to change all 4's that are detailed below to your relevant destination.
    ' I put all the processed data into Column D in my example
    ' starting from row 2 to leave a row for a header
    With ws
        ' Declare range that we are going to be considering (where the raw data is)
        Set rng = Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
        ' Loop through that data
        For Each inc In rng
            ' Find if data exists in destination
            Set f = .Columns(4).Find(inc.Value, LookIn:=xlValues)
            ' If it exists assign the row number to a variable, if not add it to the end
            If Not f Is Nothing Then
                i = f.Row
            Else
                i = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
                .Cells(i, 4) = inc.Value
            End If
            ' find last column that has been used
            c = .Cells(i, .Columns.Count).End(xlToLeft).Column + 1
            ' add the Status value to the row
            .Cells(i, c) = inc.Offset(0, 1)
        ' Loop back for next data entry
        Next inc
    End With
    ' Turn back on screen updating for normal behaviour
    Application.ScreenUpdating = True
End Sub

Excel宏根据另一列中的重复值粘贴转置

3 个答案: