I'm attempting to transpose - if that's the right application of the term - pairs of columns into repeating rows. In concrete terms, I need to go from this:
Thing1 6 0.29 5 0.23 7 0.19 8 0.11
to this:
Thing1 6 0.29
Thing1 5 0.23
Thing1 7 0.19
Thing1 8 0.11
This operation will occur with at least 7 pairs of columns for several hundred "things." The part I can't figure out is how to group/lock the pairs to be treated as one unit.
In some ways, I'm trying to do the opposite of what is normally done. One example is here: Transpose and group data but it doesn't quite fit, even if I attempt to look at it backwards.
EDIT: Another example that is similar, but I need to do almost the reverse: How to transpose one or more column pairs to the matching record in Excel?
My VBA kung fu is weak, but I'm willing to try whatever your collective wisdom suggests.
Ideas are welcome, and in any case, thank you for reading.
Here is the Excel formula solution just in case. If the source data starts at A1, then formula in the first destination cell will be =$A$1 and the 2 formulas to the right will be
= OFFSET( A$1, 0, ROW( A1 ) * 2 - 1 )
and
= OFFSET( A$1, 0, ROW( A1 ) * 2 )
copy the 3 formula cells and paste in the range below them
Update
VBA version (set r to the source range and replace c3 with the first cell in the destination range)
Set r = [a1:i1]
set d = [c3].Resize(r.Count \ 2, 3)
d.Formula = "=index(" & r.Address & ",if(column(a1)=1,1,row(a1)*2-2+column(a1)))"
Here is a VBA solution.
To implement this, press Alt+F11 to open the VBA editor.
Right click to the left side and select "Insert Module"
Paste the code into the right side of this.
You may want to change the output sheet name as I have shown in the code.
I use Sheet2 to place the transposed data, but you can use whatever you want.
After you have done this, you may close the editor and select the sheet with your non-transposed data.
Run the macro by pressing Alt+F8, clicking on the macro, and pressing Run
Sheet2 should contain the results you are looking for.
Sub ForJeremy() 'You can call this whatever you want
Dim EndCol, OutSheet, OutRow, c, x
Application.ScreenUpdating = False
EndCol = ActiveSheet.UsedRange.columns.Count
'What sheet do I put these values on?
Set OutSheet = Sheets("Sheet2") 'Put the name in the quotes
OutSheet.Cells.Delete xlShiftUp 'This clears the output sheet.
OutRow = 1
For Each c In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:A"))
For x = 2 To EndCol Step 2
OutSheet.Cells(OutRow, 1) = c.Value
OutSheet.Cells(OutRow, 2) = Cells(c.Row, x)
OutSheet.Cells(OutRow, 3) = Cells(c.Row, x + 1)
OutRow = OutRow + 1
Next x
Next c
OutSheet.Select
Application.ScreenUpdating = True
End Sub
Input:
Output:
Edit: If you wanted to add an additional column to the beginning that would also just display to the side, you would change the code like this:
For Each c In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("A:A"))
For x = 3 To EndCol Step 2 'Changed 2 to 3
OutSheet.Cells(OutRow, 1) = c.Value
OutSheet.Cells(OutRow, 2) = Cells(c.Row, 2) 'Added this line
OutSheet.Cells(OutRow, 3) = Cells(c.Row, x) 'Changed to Col 3
OutSheet.Cells(OutRow, 4) = Cells(c.Row, x + 1) 'Changed to Col 4
OutRow = OutRow + 1
Next x
Next c
To better explain this loop,
It goes through each cell in column A from the top to the bottom.
The inner loop scoots over 2 columns at a time.
So we start at column B, and next is D, and next is F .. and so on.
So once we have that value, we grab the value to the right of it as well.
That's what the Cells(c.Row, x) and Cells(c.Row, x + 1) does.
The OutSheet.Cells(OutRow, 1) = c.Value says - just make the first column match the first column.
When we add the second one, OutSheet.Cells(OutRow, 2) = Cells(c.Row, 2) 'Added this line we are saying, match the second column too.
Hope I did a decent job explaining.
Related
i have a excel sheet that looks like this:
Category Value
X 1
X 2
X 3
X 4
Y 1
Z 1
Z 2
And I would like to transform it into categories and get value rows into columns. Like that:
Category Value1 Value2 Value3 Value4
X 1 2 3 4
Y 1
Z 1 2
Guys, any idea how to do it? I am really stuck with it.
many thanks.
Walk up your data from the bottom to the top, reorganizing as you go.
Option Explicit
Sub expandValues()
Dim i As Long, mx As Long, arr As Variant, tmp As Variant
With Worksheets("sheet7")
'determine no of values and create new headers
For i = 1 To Application.Max(.Columns("B"))
.Cells(1, i + 1) = "value" & i
Next i
'transfer values
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 3 Step -1
If .Cells(i, "A").Value2 = .Cells(i - 1, "A").Value2 Then
With .Range(.Cells(i, "B"), .Cells(i, .Columns.Count).End(xlToLeft))
.Parent.Cells(i - 1, 3).Resize(1, .Columns.Count) = .Value2
End With
.Cells(i, "A").EntireRow.Delete
End If
Next i
End With
End Sub
If I m not mistaking you can simply use a pivot table:
It will make you pass from this:
to this:
you just need to put the two columns in the rows columns and values as of below:
After that you can just change the names of your columns
Here's the formula approach ,
First write this array formula in cell C2 and press Ctrl+Shift+Enter to find unique values from column A (i.e. X, Y, Z) and drag it down.
=IFERROR(INDEX($A$2:$A$8, MATCH(0, COUNTIF($C$1:C1, $A$2:$A$8), 0)),"")
Now fill your column headers for value1 , value2 and so on.
Finally write this formula in cell D2 and drag it to right and down.
=IF(COUNTIFS($A$2:$A$8,$C2,$B$2:$B$8,RIGHT(D$1,1))>0,RIGHT(D$1,1)*1,"")
Hi I have a Excel worksheet with data like this:
VISIT <48 >48 TOTAL BILLED NOT BILLED
10 4 3 7 3
I need a macro that will add the not-billed to the <48 i.e. 3+4= 7.
7 would then replace the 4.
I tried C13=C13+F13 but it does not compile.
From your question, I wrote a tested and working macro as requested.
Assuming your Cell columns is the same as in the section below. (Note that the rows may differ and may start on different positions)
You can select the rows that needs to be processed as displayed in the picture.
Sub calculate()
' Calculates for each row in any selection
' Takes value in C and add value in F if value in F is larger than 0 then afterwards makes value in f equal to 0
' Asumes that Column "C" have the "Visit" and Column "F" is the "Not Billed" columns
Dim sel As Range
Dim rw As Range
Dim l As Long
Set sel = Selection
For Each rw In sel ' Adapt this to however you need to specify the selection you want to work with
If (Cells(rw.Row, 6).Value > 0) Then ' Test if the value need to be processed
l = Cells(rw.Row, 3).Value + Cells(rw.Row, 6).Value
Cells(rw.Row, 6).Value = 0
Cells(rw.Row, 3).Value = l
'Cells(rw.Row, 3) would be column C
'Cells(rw.Row, 6) would be column F
End If
Next
End Sub
After running the macro your file will look like:
Let me know if it works for you.
I have a set of data in two dimensions, like so:
A B C
A - 9 4
B 24 - 13
C 3 12 -
It represents relationships between two entities. I would like to return a list of those values ranked, such as:
AB:4
AC:5
BA:1
BC:2
CA:6
CB:3
Any thoughts on the best way to approach this?
Create a copy of your source matrix with, assuming layout as below,
=IFERROR(RANK(B2,$B$2:$D$4),"")
in G2 copied down and across to I4. From this 2D version of your rankings create a PivotTable with multiple consolidation ranges ("reverse pivot" - maybe Alt+D, P). Double click on the Totals intersect. If results are copied back in to source sheet as below (for convenience), add =Q2&R2&": "&S2 in U2 (or adjust accordingly) and copy down to suit:
May be more appropriate for larger datasets!
You could also use VBA to create a flat table from your summary table. From then, it would be easy to sort the pairs based on their numerical value, using CONCATENATE and RANK.
Let's assume this is your starting table:
Here is the VBA code that would transform this pivot table to a flat table:
(Go to Developer tab -> Visual Basic -> Insert -> Module -> Copy-paste the code here)
Then click on Run (green Play sign)
Sub ReversePivotTable()
' Before running this, make sure you have a summary table with column headers.
' The output table will have three columns.
Dim SummaryTable As Range, OutputRange As Range
Dim OutRow As Long
Dim r As Long, c As Long
On Error Resume Next
Set SummaryTable = ActiveCell.CurrentRegion
With SummaryTable
r = Application.Match("Totals", Columns(1), False)
c = Application.Match("Total", Rows(1), False)
End With
Set SummaryTable = SummaryTable.Resize(r - 1, c - 1)
MsgBox SummaryTable.Address
If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then
MsgBox "Select a cell within the summary table.", vbCritical
Exit Sub
End If
SummaryTable.Select
Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)
' Convert the range
OutRow = 2
Application.ScreenUpdating = False
OutputRange.Range("A1:C3") = Array("Column1", "Column2", "Column3")
For r = 2 To SummaryTable.Rows.Count
For c = 2 To SummaryTable.Columns.Count
OutputRange.Cells(OutRow, 1) = SummaryTable.Cells(r, 1)
OutputRange.Cells(OutRow, 2) = SummaryTable.Cells(1, c)
OutputRange.Cells(OutRow, 3) = SummaryTable.Cells(r, c)
OutputRange.Cells(OutRow, 3).NumberFormat = SummaryTable.Cells(r, c).NumberFormat
OutRow = OutRow + 1
Next c
Next r
End Sub
You will get a flat table like this:
Then, use CONCATENATE and RANK to get a column of pairs and ranks.
This would be the final result:
I have a 2 columns that look like:
field group1
a 1.2
b 0.2
c 2.4
field group2
a 0.2
c 0.8
field group3
c 0.6
d 0.8
and so forth. I have been pondering about this for a while but can't seem to find a good way.
Is there a efficient way to make the dataset look like:
field group1 group2 group3
a 1.2 0.2
b 0.2
c 2.4 0.8 0.6
d 0.8
and so forth. Any help or idea?
For a one-off, you can probably do it just with formulae to identify which groups a row is in and then pivot, as described by others in the comments to your question.
However, for repeated use / less hassle the below should work.
This works on your test data and outputs on a new sheet according to your desired output in the question.
It works in memory so it should have good performance when scaled up to thousands of cells.
Sub blah()
'Declarations
Dim outWs As Worksheet
Dim inArr, outArr
Dim vector(), groups()
Dim outC As Collection
Dim currentGroup As Long
Dim i As Long, j As Long
Dim key
'load data
inArr = Selection.Value
Set outC = New Collection
'iterate through
For i = LBound(inArr, 1) To UBound(inArr, 1)
If inArr(i, LBound(inArr, 2)) Like "field*" Then 'new group
currentGroup = currentGroup + 1
ReDim Preserve groups(1 To currentGroup)
groups(currentGroup) = inArr(i, LBound(inArr, 2) + 1) 'assign group name
Else 'is a record/field
key = inArr(i, LBound(inArr, 2))
'retrieve existing, ignoring the exception thrown if key does not exist
On Error Resume Next
vector = outC(key)
If Err.Number = 5 Then 'error raised when key does not exist
ReDim vector(0 To currentGroup)
vector(0) = key 'add key
Else
outC.Remove (key) 'the reference of item is immutable so we must remove and add again
ReDim Preserve vector(0 To currentGroup) 'resize vector
End If
On Error GoTo 0
vector(currentGroup) = inArr(i, LBound(inArr, 2) + 1) 'assign value to current group in vector
outC.Add vector, key 'add to results
Erase vector
End If
Next i
'Process our results collection into an array suitable for dumping to a sheet
ReDim outArr(1 To outC.Count, 1 To currentGroup + 1)
For i = 1 To outC.Count
For j = 0 To UBound(outC(i))
outArr(i, j + LBound(outArr, 2) - LBound(outC(i))) = outC(i)(j)
Next j
Next i
'dump data
With ActiveWorkbook.Worksheets.Add
.Range(.Cells(1, 2), .Cells(1, 1 + UBound(groups))).Value = groups
.Range(.Cells(2, 1), .Cells(1 + UBound(outArr, 1), UBound(outArr, 2))).Value = outArr
End With
Exit Sub
End Sub
I hope that helps.
so i have an idea, its not beautiful but it will probably work...
copy your whole field column and paste it to a fresh sheet, use data tab and hit remove duplicates, if you transpose that so your top row is Field, a, b, c, d you can drop a formula thats something like this (untested) "=INDEX(Sheet1!B:B, MATCH($B$1,Sheet1!A1:A3,0))"
the search range in match is intentionally small and left without $ to that if you drag this formula down it will search a little further(A2:A4,A3:A5,etc) once you get all of them just find/replace all the N/As remove blanks and your good
if i have time i will try and put together a little macro that would be a lot cleaner...
In outline: Create a copy of your group1 column, filter it for values greater than 0 and delete these. Fill the blanks with the respective groups and then pivot.
i would rearrange data first, with a macro, this way:
Sub sa()
For Each cl In Range("B2:B1000").Cells
If IsNumeric(cl.Value) And Not IsEmpty(cl.Value) Then
If Not IsNumeric(cl.Offset(-1, 0).Value) Then
cl.Offset(0, 1).Value = cl.Offset(-1, 0).Value
Else
cl.Offset(0, 1).Value = cl.Offset(-1, 1).Value
End If
End If
Next
End Sub
such that data would be rearranged with this column assignment:
[field] [value] [group]
then it would be easy to do what you want, just create a pivot table... tell me in the commentaries if in need of further help...
have currently browsed the forums and have came up with a code to compare two columns from two separate excel books and then highlight anything matching with the CompareRange. Here is a few more details about the problem:
I have two excel sheets. And data like this in each sheet:
(First Sheet) (Second Sheet)
•A B N O
•7 .7 3 .56
•6 .6 8 .45
•5 .5 9 .55
•4 .4 11 .2
•3 .3 8 .22
•2 .2 9 .55
•1 .1 8 .54
As you can see, given this example nothing should be highlighted once the macro is run since nothing from Column A or B from the first sheet matches directly with Column N & O from the second sheet. The problem is that with the macro (module) I have come up with will highlight "3" from Column A and ".2" from Column B, just because they appear in Column N & Column O respectivally.
What I want: I only want a number to be highlighted if both the numbers "7" & ".7" are matched in the same row of Column N & Column O on the other spreadsheet. I have no idea how to do this. To be a little more precise, I'll give an example. Say I edited the data to be like this.
(First Sheet) (Second Sheet)
•A B N O
•7 .7 3 .56
•8 .45 8 .45
•5 .5 9 .55
•11 .4 11 .2
•3 .3 8 .22
•2 .2 9 .55
•1 .1 8 .54
With this data, I would want the second row of A & B ("8" & ".45") highlighted, while my error "3" of Column A and ".2" of Column B is not highlighted. Also, I would like it if row 4 of Column A & B ("11" & ".4") is not highlighted at all either, just because in O it is .2 and in B it would be .4 even though the 11's match.
Please advise. Thanks in advance.
Attached is the macro/module I have entered in which is working kind of correctly but producing the mistake.
And also, (kind of a lesser problem), both the files with data will have the same header, example would be if Column A & Column N both had "Dogs" as it's title in Row 1 and Column B & O both had "Cats" as it's title in Row 1. Is there anyway the macro can be adjusted so it compares those two columns between the two workbooks without me even having to select or assigning a range? Thank you so much.
Sub Find_Matches()
Dim Column1 As Range
Dim Column2 As Range
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
If Column1.Columns.Count > 1 Then
Do Until Column1.Columns.Count = 1
MsgBox "You can only select 1 column"
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
Loop
End If
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
If Column2.Columns.Count > 1 Then
Do Until Column2.Columns.Count = 1
MsgBox "You can only select 1 column"
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
Loop
End If
If Column2.Rows.Count <> Column1.Rows.Count Then
Do Until Column2.Rows.Count = Column1.Rows.Count
MsgBox "The second column must be the same size as the first"
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
Loop
End If
If Column1.Rows.Count = 65536 Then
Set Column1 = Range(Column1.Cells(1), Column1.Cells(ActiveSheet.UsedRange.Rows.Count))
Set Column2 = Range(Column2.Cells(1), Column2.Cells(ActiveSheet.UsedRange.Rows.Count))
End If
Dim CompareRange As Variant, x As Variant, y As Variant
' Set CompareRange equal to the range to which you will
' compare the selection.
Set CompareRange = Workbooks("Book4").Worksheets("Sheet1").Range("N2:N7")
Set CompareRange1 = Workbooks("Book4").Worksheets("Sheet1").Range("O2:O7")
' NOTE: If the compare range is located on another workbook
' or worksheet, use the following syntax.
' Set CompareRange = Workbooks("Book2"). _
' Worksheets("Sheet2").Range("C1:C5")
'
' Loop through each cell in the selection and compare it to
' each cell in CompareRange.
For Each x In Column1
For Each y In CompareRange
If x = y Then
x.Interior.Color = vbYellow
End If
'x.Offset(0, 5) = x
Next y
Next x
For Each x In Column2
For Each y In CompareRange1
If x = y Then
x.Interior.Color = vbYellow
End If
'x.Offset(0, 5) = x
Next y
Next x
End Sub
Replace both of your loops with one that compares both pairs of cells at the same time:
For i = 1 To Column1.Rows.Count
For j = 1 To compareRange.Rows.Count
If Column1.Cells(i, 1) = compareRange.Cells(j, 1) Then
If Column2.Cells(i, 1) = compareRange1.Cells(j, 1) Then
Column1.Cells(i, 1).Interior.Color = vbYellow
Column2.Cells(i, 1).Interior.Color = vbYellow
End If
End If
Next j
Next i