Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Multiple same rows only one column changes
Hi:
I want to arrange some data in Excel. The data are in the following format: Contact1 Address1 Phone1 Email1 Contact1 Address1 Phone1 Email2 Contact1 Address1 Phone2 Email1 Contact1 Address1 Phone2 Email2 and so on.... As you can see, only the column that contains phones and emails changes. I want to put them in a new sheet in the following format. Contact1 Address1 Phone1 Phone2 Email1 Email2 (all the data for a particular contact in a row) Do you have any idea how should I tackle this issue? Thanks a lot in advance. |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Multiple same rows only one column changes
Try this code.
In the test example the data is in the range A1: D4. Function SwingArray(arr1 As Variant, _ colToTest As Long, _ StartCol As Long, _ Optional lDiscardLastCols As Long, _ Optional lMaxRows As Long = -1, _ Optional lMaxCols As Long = -1) As Variant 'takes one multi-column 2D array and swings the elements 'that have the same value in colToTest to the row where 'this value was found first. Column colToTest will only 'hold unique values in the resulting array. 'StartCol is the column where the copying of the elements 'starts from. '-------------------------------------------------------- Dim arr2() Dim arr3() 'As Long Dim i As Long Dim n As Long Dim c As Long Dim c2 As Long Dim c3 As Long Dim maxItems As Long Dim uCo As Long Dim LBR1 As Long Dim UBR1 As Long Dim LBC1 As Long Dim UBC1 As Long Dim tempIdx 'As Long Dim arrError(0 To 0) Dim bResumeNext As Boolean On Error GoTo ERROROUT LBR1 = LBound(arr1, 1) UBR1 = UBound(arr1, 1) LBC1 = LBound(arr1, 2) UBC1 = UBound(arr1, 2) - lDiscardLastCols 'adjust UBR1 to account for empty elements 'these empty element have to be at the 'bottom of the array if they are there '----------------------------------------- For i = LBR1 To UBR1 If arr1(i, colToTest) = Empty And arr1(i, colToTest) < 0 Then UBR1 = i - 1 Exit For End If Next ReDim arr3(LBR1 To UBR1) 'As Long 'find and mark the doubles 'get the maximum number of doubles '--------------------------------- tempIdx = arr1(LBR1, colToTest) For i = LBR1 + 1 To UBR1 If Not arr1(i, colToTest) = tempIdx Then tempIdx = arr1(i, colToTest) uCo = uCo + 1 c2 = 0 Else arr3(i) = 1 c2 = c2 + 1 If c2 maxItems Then maxItems = c2 End If End If Next 'adjust the final array 'LBound will be as the original array '------------------------------------ If lMaxRows = -1 And lMaxCols = -1 Then ReDim arr2(LBR1 To uCo + LBR1, _ LBC1 To (UBC1) + maxItems * (((UBC1 + 1) - StartCol))) Else If uCo + LBR1 lMaxRows And _ ((UBC1) + maxItems * (((UBC1 + 1) - StartCol))) + (1 - LBC1) lMaxCols Then ReDim arr2(LBR1 To lMaxRows - (1 - LBR1), LBC1 To lMaxCols - (1 - LBC1)) bResumeNext = True Else If uCo + LBR1 lMaxRows Then ReDim arr2(LBR1 To lMaxRows - (1 - LBR1), _ LBC1 To (UBC1) + maxItems * (((UBC1 + 1) - StartCol))) bResumeNext = True Else If ((UBC1) + maxItems * (((UBC1 + 1) - StartCol))) + (1 - LBC1) lMaxCols Then ReDim arr2(LBR1 To uCo + LBR1, LBC1 To lMaxCols - (1 - LBC1)) bResumeNext = True Else ReDim arr2(LBR1 To uCo + LBR1, _ LBC1 To (UBC1) + maxItems * (((UBC1 + 1) - StartCol))) End If End If End If End If n = LBR1 - 1 If bResumeNext Then 'to cover array OutofBounds errors On Error Resume Next End If 'swing the elements from vertical to horizontal '---------------------------------------------- For i = LBR1 To UBR1 If Not arr3(i) = 1 Then 'copy first row in full n = n + 1 For c = LBC1 To UBC1 arr2(n, c) = arr1(i, c) Next c3 = UBC1 + 1 Else 'copy subsequent rows from specified start column '------------------------------------------------ For c = StartCol To UBC1 arr2(n, c3) = arr1(i, c) c3 = c3 + 1 Next End If Next SwingArray = arr2 Exit Function ERROROUT: arrError(0) = "ERROR" SwingArray = arrError End Function Sub test() Dim arr Dim arr2 arr = Range(Cells(1), Cells(4, 4)) arr2 = SwingArray(arr, 1, 3) Range(Cells(6, 1), Cells(UBound(arr2) + 5, UBound(arr2, 2))) = arr2 End Sub I was using this on data where the first column of the array was holding Long data, so I commented out the Longs where needed. RBS "Lekaj" wrote in message ... Hi: I want to arrange some data in Excel. The data are in the following format: Contact1 Address1 Phone1 Email1 Contact1 Address1 Phone1 Email2 Contact1 Address1 Phone2 Email1 Contact1 Address1 Phone2 Email2 and so on.... As you can see, only the column that contains phones and emails changes. I want to put them in a new sheet in the following format. Contact1 Address1 Phone1 Phone2 Email1 Email2 (all the data for a particular contact in a row) Do you have any idea how should I tackle this issue? Thanks a lot in advance. |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Multiple same rows only one column changes
THANK YOU VERY MUCH. It is perfectly working as I wanted.
Have a nice weekend!!! F.L. |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Multiple same rows only one column changes
One more question! I have thousands of records that needs to be
arranged in this way. When I try with more than 400 records it doesn't work. Do you have any thoughts on this? Thnx, F.L. |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Multiple same rows only one column changes
It should just work the same.
Can you post the code and tell what goes wrong? RBS "Lekaj" wrote in message ... One more question! I have thousands of records that needs to be arranged in this way. When I try with more than 400 records it doesn't work. Do you have any thoughts on this? Thnx, F.L. |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Multiple same rows only one column changes
It is working fine -- my mistake.
Thnx again, F.L. |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Transposing One Column to Multiple Rows | Excel Worksheet Functions | |||
Select multiple rows and add a value in a column | Excel Programming | |||
Way to put multiple rows into the same column. | Excel Discussion (Misc queries) | |||
Multiple rows to one column | Excel Programming | |||
Problem when trying to convert one column with multiple rows to one row with multiple column | Excel Programming |