[英]Excel macro to paste transpose based on repeated values in another column
第一組數據是前兩列中的may數據片段(運行成千上萬行)。
第一列具有不同狀態的重復票號。 我想為每張票都有一個唯一的行,並為相應的列提供各種狀態(類似轉置)。 參見下圖:
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
我不確定我是否理解湯姆為什么給你他的建議。 從記錄中獲取記錄的宏並不是一個好主意,因為記錄的代碼具有非動態性質,而不是數據的動態性質。
這是兩個選擇。 第一個是您要的內容(運行“ 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
這將需要進入標准模塊。 讓我們知道,如果你需要這方面的額外援助。
問候,扎克·巴雷斯
此過程假定以下條件:
數據范圍從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
建議訪問以下頁面,以更深入地了解所使用的資源:
變量和常量 , 應用程序對象(Excel) , Excel對象
帶語句 , 對於每個...下一個語句 , 如果...則...其他語句
不過,請讓我知道有關程序的任何問題
今天過得很慢,所以.....使用vba可以完成您想要的事情。 您也可以按照Scott所說的通過公式甚至使用數據透視表來實現。 但是,從問題的角度看,您正在尋找動態的東西,該東西會自動擴展以包括新事件,而這些事件很難用公式來解決。
我已經對此進行了評論,希望您將來能夠輕松理解。 這可能不是唯一的方法,也不一定是最好的方法。
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.