First time post - Transpose variance - Any help appreciated
- Thread starter BryanH
- Start date
shrivallabha
Excel Ninja
Welcome to Chandoo.org forums.
I have couple of questions for you.
1. How do you identify the table to process? Does it start from a specific cell e.g. B3 is top left cell in your example.
2. Where do you want to copy the results? To another sheet or just below your current data as you have shown?
I have couple of questions for you.
1. How do you identify the table to process? Does it start from a specific cell e.g. B3 is top left cell in your example.
2. Where do you want to copy the results? To another sheet or just below your current data as you have shown?
Marc L
Excel Ninja
Hi,
a code demonstration upon post #1 sample workbook :
Code:
Sub Demo()
With Sheet1
With .[B3].CurrentRegion
If .Columns.Count = 1 Or .Rows.Count = 1 Then Beep: Exit Sub
N& = Application.CountA(.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1))
If N = 0 Then Beep: Exit Sub
VA = .Value
End With
.Activate
End With
Application.ScreenUpdating = False
ReDim TR(1 To N, 1 To 3)
For R& = 2 To UBound(VA)
For C& = 2 To UBound(VA, 2)
If VA(R, C) > "" Then
T& = T& + 1
TR(T, 1) = VA(R, 1)
TR(T, 2) = VA(1, C)
TR(T, 3) = VA(R, C)
End If
Next
Next
With [A21]
.CurrentRegion.Clear
With .Offset(, 1).Resize(N, 3)
[B4].Copy: .Columns(1).PasteSpecial xlPasteFormats
[C3:C4].Copy: .Columns("B:C").PasteSpecial xlPasteFormats, Transpose:=True
Application.CutCopyMode = False
.Value = TR
End With
.Select
End With
End SubDo you like it ? So thanks to click on bottom right Like !
Last edited:
Somendra Misra
Excel Ninja
Hi,
See the file, for formula solutions, (I assume you want to transpose Table 1 to Table 2), note I had inserted a helper column A next to table 1. Then created some named range, refer them in name manager. The solution is in the range G21:I36.
Regards,
See the file, for formula solutions, (I assume you want to transpose Table 1 to Table 2), note I had inserted a helper column A next to table 1. Then created some named range, refer them in name manager. The solution is in the range G21:I36.
Regards,
BryanH
New Member
Hi Shrivallabha, thanks for your interest
Answers
1. B2 will be where the table starts
2. Create another sheet would be perfect (sheet name ORDER if that helps)
BryanH
New Member
BryanH
New Member
Another way to look at it! Thanks Somendra I will be able to use this in other applications as well - This forum is awesome
shrivallabha
Excel Ninja
OK. Here's a code which should work for you.
Code:
Public Sub TransposeData()
Dim rStart As Range
Dim lngLastRow As Long, lngLastCol As Long, lngFillRow As Long
Dim wsDest As Worksheet
Set rStart = Range("B2")
lngLastRow = Cells(Rows.Count, rStart.Column).End(xlUp).Row
lngLastCol = Cells(rStart.Row, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
On Error Resume Next
Set wsDest = Sheets("ORDER")
If wsDest Is Nothing Then
Set wsDest = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
wsDest.Name = "ORDER"
Else
wsDest.UsedRange.EntireRow.Delete
End If
On Error GoTo 0
For i = rStart.Row + 1 To lngLastRow
For j = rStart.Column + 1 To lngLastCol
If Len(Cells(i, j).Value) > 0 Then
lngFillRow = wsDest.Cells(Rows.Count, rStart.Column).End(xlUp).Row + 1
wsDest.Cells(lngFillRow, rStart.Column).Value = Cells(i, rStart.Column).Value
wsDest.Cells(lngFillRow, rStart.Column + 1).Value = Cells(rStart.Row, j).Value
wsDest.Cells(lngFillRow, rStart.Column + 2).Value = Cells(i, j).Value
End If
Next j
Next i
Application.ScreenUpdating = True
End SubBryanH
New Member
Hi Shrivallabha - a variance to this possibly will save a step
Can I transpose only fonts that are, for instance, Red? That will resolve my Major issue
shrivallabha
Excel Ninja
Modify the following block:
to:
Note: Do not forget to modify the color number that suits your case.
Code:
If Len(Cells(i, j).Value) > 0 Then
lngFillRow = wsDest.Cells(Rows.Count, rStart.Column).End(xlUp).Row + 1
wsDest.Cells(lngFillRow, rStart.Column).Value = Cells(i, rStart.Column).Value
wsDest.Cells(lngFillRow, rStart.Column + 1).Value = Cells(rStart.Row, j).Value
wsDest.Cells(lngFillRow, rStart.Column + 2).Value = Cells(i, j).Value
Code:
If Len(Cells(i, j).Value) > 0 Then
lngFillRow = wsDest.Cells(Rows.Count, rStart.Column).End(xlUp).Row + 1
wsDest.Cells(lngFillRow, rStart.Column).Value = Cells(i, rStart.Column).Value
wsDest.Cells(lngFillRow, rStart.Column + 1).Value = Cells(rStart.Row, j).Value
wsDest.Cells(lngFillRow, rStart.Column + 2).Value = Cells(i, j).Value
If Cells(i, j).Font.Color = 255 Then 'Change this color number to suit
wsDest.Cells(lngFillRow, rStart.Column + 2).Font.Color = 255
End IfNote: Do not forget to modify the color number that suits your case.
BryanH
New Member
Hi Again Shrivallabha, I have uploaded a spreadsheet with the code in but while it creates the new worksheet no data is transposed - specifically I only want the red data. If you could troubleshoot it for me I will be eternally grateful and generous..thanks
NARAYANK991
Excel Ninja
Hi Bryan ,
See if this is OK.
Narayan
See if this is OK.
Narayan
Marc L
Excel Ninja
Bryan, try this tiny code ! (with your post #11 sample workbook)
Code:
Sub DemoTransposeRed()
Dim AR(), Rg As Range
With Sheet4.[B3].CurrentRegion
For Each Rg In .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
If Rg.Font.ColorIndex = 3 And Rg.Value > "" Then
R& = R& + 1
ReDim Preserve AR(1 To 3, 1 To R)
AR(1, R) = .Cells(Rg.Row - 2, 1).Value
AR(2, R) = .Cells(1, Rg.Column - 1).Value
AR(3, R) = Rg.Value
End If
Next
End With
If Evaluate("ISREF(ORDER!A1)") Then Worksheets("ORDER").UsedRange.Clear _
Else Worksheets.Add(, Sheet4).Name = "ORDER"
With Worksheets("ORDER")
.Cells(2).Resize(R, 3).Value = Application.Transpose(AR)
.Activate
End With
End SubYou like ? So thanks …
Last edited: