Im trying to make a macro on Excel using VBA that will transpose each Data set into 1 row only.
Initial Format of Table
No. 1
Code A1B1
Date 10/25/21
No. 2
Code A2B2
Date 10/26/21
Outcome should be like this in Sheet2
No. Code Date
1 A1B2 10/25/21
2 A2B2 10/26/21
I tried to copy Row that contain "No.". But I want it to be extracted to cell B2. Where should I start?
Sub CopyNo()
Dim LastRow As Long
LastRow = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
With Worksheets("Sheet2").Range("A1:A" & LastRow)
Worksheets("Sheet1").Range("A1:A" & LastRow).EntireRow.Copy .Range("A1")
With .Offset
.Replace "No.", "=No.", xlPart
On Error Resume Next
.Offset(1).SpecialCells(xlConstants).EntireRow.Delete
On Error GoTo 0
.Replace "=No.", "No.", xlPart
End With
End With
End Sub
CodePudding user response：
This is a type of Pivot Table, but with no aggregation of the results (Not something that can be done in the regular Pivot Tables for Excel)
But you can do this in Power Query, available in Windows Excel 2010 and Office 365
To use Power Query
- Select some cell in your Data Table
Data => Get&Transform => from Table/Range- When the PQ Editor opens:
Home => Advanced Editor - Make note of the Table Name in Line 2
- Paste the M Code below in place of what you see
- Change the Table name in line 2 back to what was generated originally.
- Read the comments in the code and explore the
Applied Stepsto understand the algorithm
M Code
let
//Read in the data
//Change table name in next line to actual table name in your worksheet
Source = Excel.CurrentWorkbook(){[Name="Table22"]}[Content],
//Custom function
//see credits for explanation
pivot = fnPivotAll(Source, "Column1","Column2"),
//set data types
#"Changed Type" = Table.TransformColumnTypes(pivot,{
{"No.", Int64.Type},
{"Code", type text},
{"Date", type date}})
in
#"Changed Type"
Note that you will need to use a custom function for this solution
- To enter the custom function:
Data => GetData => From other sources => Blank Query- When the PQ Editor opens:
Home => Advanced Editor- Replace the code with the code below
- over on the right hand menu, change Query Name to
fnPivotAll - See the link in the credits for understanding the algorithm and reason for doing it this way.
//credit: Cam Wallace https://www.dingbatdata.com/2018/03/08/non-aggregate-pivot-with-multiple-rows-in-powerquery/
//rename fnPivotAll
(Source as table,
ColToPivot as text,
ColForValues as text)=>
let
PivotColNames = List.Buffer(List.Distinct(Table.Column(Source,ColToPivot))),
#"Pivoted Column" = Table.Pivot(Source, PivotColNames, ColToPivot, ColForValues, each _),
TableFromRecordOfLists = (rec as record, fieldnames as list) =>
let
PartialRecord = Record.SelectFields(rec,fieldnames),
RecordToList = Record.ToList(PartialRecord),
Table = Table.FromColumns(RecordToList,fieldnames)
in
Table,
#"Added Custom" = Table.AddColumn(#"Pivoted Column", "Values", each TableFromRecordOfLists(_,PivotColNames)),
#"Removed Other Columns" = Table.RemoveColumns(#"Added Custom",PivotColNames),
#"Expanded Values" = Table.ExpandTableColumn(#"Removed Other Columns", "Values", PivotColNames)
in
#"Expanded Values"
`
CodePudding user response：
Transpose Vertical Data
- It is assumed that your data is contiguous (no empty rows (or empty columns)) and it starts in cell
A1. - It is assumed that the destination headers are already written (in this case in the range
A1:C1). - Adjust the values in the constants section.
Option Explicit
Sub TransposeVerticalData()
Const ProcTitle As String = "Transpose Vertical Data"
' Source
Const sName As String = "Sheet1"
Const sCriteriaList As String = "No.,Code,Date"
Const shColumn As Long = 1 ' Header Column
Const svColumn As Long = 2 ' Value Column
' Destination
Const dName As String = "Sheet2"
Const dFirst As String = "A2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source (Worksheet, Range, Rows Count, Data Array, Criteria Array)
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion.Resize(, svColumn)
Dim srCount As Long: srCount = srg.Rows.Count
Dim sData As Variant: sData = srg.Value
Dim sCriteria() As String: sCriteria = Split(sCriteriaList, ",")
' Destination (Rows Count, Columns Count, Data Array)
Dim drCount As Long
drCount = Application.CountIf(srg.Columns(1), sCriteria(0))
If drCount = 0 Then Exit Sub
Dim dcCount As Long: dcCount = UBound(sCriteria) 1
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' Additional 'For Next Loop' Variables
Dim sValue As Variant ' Source Value (First Column of the Source Array)
Dim sIndex As Variant ' Index of the Source Value in Source Criteria Array
Dim sr As Long ' Source Array Rows Counter
Dim dr As Long ' Destination Array Rows Counter
' Write the values from the Source Array to the Destination Array.
For sr = 1 To srCount
sValue = sData(sr, shColumn)
sIndex = Application.Match(sValue, sCriteria, 0)
If IsNumeric(sIndex) Then ' Number i.e. 'sValue' found in 'sCriteria'
If sIndex = 1 Then ' i.e. 'sValue = sCriteria(0)'
dr = dr 1
'Else ' i.e. 'sValue <> sCriteria(0)'
End If
dData(dr, sIndex) = sData(sr, svColumn) ' write
'Else ' Error Value i.e. 'sValue' not found in 'sCriteria'
End If
Next sr
' Write the values from the Destination Array to the Destination Range
' (Worksheet, First Cell, Range).
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
drg.Value = dData
' Clear the Clear Range, the range below the Destination Range, to remove
' possibly remaining data of a previously larger data set.
Dim dcrg As Range: Set dcrg = _
drg.Resize(dws.Rows.Count - drg.Row - drCount 1).Offset(drCount)
dcrg.Clear
' Inform.
MsgBox "Vertical data transposed.", vbInformation, ProcTitle
End Sub