Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
help creating a marco please
name lx
A H1 A H1 A H2 A H3 B H1 B H2 name lx A H1£¬H2£¬H3 B H1£¬H2 thx excel2003 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
help creating a marco please
This is one way of doing it.
It presumes your original data is in columns A and B and the new data will be dumped in columns D and E. If speed is important then I would use Olaf Schmidt's dhSortedDictionary, which is in the dll dhRichClient and that can be downloaded from he http://www.datenhaus.de/Downloads/dhRichClientDemo.zip Sub test() Dim i As Long Dim x As Long Dim arr Dim coll1 As Collection Dim coll2 As Collection Dim coll3 As Collection Dim collIDX As Collection Dim lIDX As Long Dim FR As Long Dim LR As Long LR = Cells(65536, 1).End(xlUp).Row FR = Cells(LR, 1).End(xlUp).Row arr = Range(Cells(FR, 1), Cells(LR, 2)) Set coll1 = New Collection Set coll2 = New Collection Set coll3 = New Collection Set collIDX = New Collection On Error Resume Next 'skipping duplicate keys For i = 1 To UBound(arr) 'adding unique column 1 items A etc. coll1.Add arr(i, 1), arr(i, 1) 'to keep track of the position of the first unique column 1 items If Err.Number = 0 Then x = x + 1 collIDX.Add x, arr(i, 1) End If 'adding unique rows A,H1 etc. coll2.Add arr(i, 1), arr(i, 1) & arr(i, 2) 'to keep track of unique column 2 items coll3.Add arr(i, 2), arr(i, 1) & arr(i, 2) Err.Clear 'needed as we do: If Err.Number = 0 Next i On Error GoTo 0 ReDim arr(1 To coll1.Count, 1 To 2) For i = 1 To coll1.Count arr(i, 1) = coll1(i) Next i For i = 1 To coll2.Count lIDX = collIDX(coll2(i)) If IsEmpty(arr(lIDX, 2)) Then arr(lIDX, 2) = coll3(i) Else arr(lIDX, 2) = arr(lIDX, 2) & "£¬" & coll3(i) End If Next i Range(Cells(4), Cells(UBound(arr), 5)) = arr End Sub RBS "lsy" wrote in message ... name lx A H1 A H1 A H2 A H3 B H1 B H2 name lx A H1£¬H2£¬H3 B H1£¬H2 thx excel2003 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
help creating a marco please
Maybe this?
Sub lineuplikeValues() mc = 1' change to your column NUMBER For i = Cells(Rows.Count, mc).End(xlUp).Row To 2 Step -1 If Cells(i, mc) = Cells(i - 1, mc) Then Cells(i - 1, mc + 1).Value = _ Cells(i - 1, mc + 1) & ", " & Cells(i, mc + 1) Rows(i).Delete End If Next End Sub -- Don Guillett Microsoft MVP Excel SalesAid Software "lsy" wrote in message ... name lx A H1 A H1 A H2 A H3 B H1 B H2 name lx A H1£¬H2£¬H3 B H1£¬H2 thx excel2003 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
help creating a marco please
As I needed this routine myself, I have worked it out a bit further to make
it more generic (works both with 0-based and 1-based arrays and you can specify the group column and the find column) and also made a version based on cSortedDictionary and this will have both the group column and the find items sorted. The second version is about twice as fast if that matters. Rather than concatenating the items in the second column I have put them in different columns in a 2-D array as that gives more flexibility. Function GroupUniqueArrayElements(vArray As Variant, _ Optional lGroupColumn As Long = -1, _ Optional lFindColumn As Long = -1) As Variant Dim i As Long Dim x As Long Dim coll1 As Collection Dim coll2 As Collection Dim coll3 As Collection Dim collIDX As Collection Dim arrColumns Dim lIDX As Long Dim lCols As Long Dim LB As Long Dim UB As Long Dim LB2 As Long Dim UB2 As Long Dim arrResult Set coll1 = New Collection Set coll2 = New Collection Set coll3 = New Collection Set collIDX = New Collection LB = LBound(vArray) UB = UBound(vArray) LB2 = LBound(vArray, 2) UB2 = UBound(vArray, 2) If lGroupColumn = -1 Then lGroupColumn = LB2 End If If lFindColumn = -1 Then lFindColumn = UB2 End If ReDim arrColumns(LB To UB) As Long On Error Resume Next 'skipping duplicate keys If LB = 0 Then x = -1 'so collIDX will start with item 0 End If For i = LB To UB 'adding unique column 1 items A etc. coll1.Add vArray(i, lGroupColumn), vArray(i, lGroupColumn) 'to keep track of the position of the first unique column 1 items If Err.Number = 0 Then x = x + 1 collIDX.Add x, vArray(i, lGroupColumn) End If 'so we can if a new item was added with Err.Number = 0 Err.Clear 'adding unique rows A,H1 etc. coll2.Add vArray(i, lGroupColumn), _ vArray(i, lGroupColumn) & vArray(i, lFindColumn) 'to keep track of the number of column 2 items per unique column 1 item If Err.Number = 0 Then lIDX = collIDX.Item(vArray(i, lGroupColumn)) arrColumns(lIDX) = arrColumns(lIDX) + 1 If arrColumns(lIDX) lCols Then lCols = arrColumns(lIDX) End If End If 'to keep track of unique column 2 items coll3.Add vArray(i, lFindColumn), vArray(i, lGroupColumn) & vArray(i, lFindColumn) Err.Clear 'needed as we do: If Err.Number = 0 Next i On Error GoTo 0 ReDim arrResult(LB To coll1.Count - (1 - LB), LB2 To lCols + 1 - (1 - LB2)) 'fill in the unique (per column 1 item) column 2 items For i = 1 To coll2.Count lIDX = collIDX(coll2(i)) arrResult(lIDX, LB2) = arrResult(lIDX, LB2) + 1 arrResult(lIDX, arrResult(lIDX, LB2) + 1 - (1 - LB2)) = coll3(i) Next i 'fill in the unique column 1 items For i = 1 To coll1.Count arrResult(i - (1 - LB), lGroupColumn) = coll1(i) Next i GroupUniqueArrayElements = arrResult End Function Function GroupUniqueArrayElementsSorted(vArray As Variant, _ Optional lGroupColumn As Long = -1, _ Optional lFindColumn As Long = -1) As Variant Dim i As Long Dim x As Long Dim cSD1 As cSortedDictionary Dim cSD2 As cSortedDictionary Dim cSD3 As cSortedDictionary Dim cSDIDX As cSortedDictionary Dim arrColumns Dim lIDX As Long Dim lCols As Long Dim LB As Long Dim UB As Long Dim LB2 As Long Dim UB2 As Long Dim arrResult Set cSD1 = New cSortedDictionary Set cSD2 = New cSortedDictionary Set cSD3 = New cSortedDictionary Set cSDIDX = New cSortedDictionary LB = LBound(vArray) UB = UBound(vArray) LB2 = LBound(vArray, 2) UB2 = UBound(vArray, 2) If lGroupColumn = -1 Then lGroupColumn = LB2 End If If lFindColumn = -1 Then lFindColumn = UB2 End If ReDim arrColumns(LB To UB) As Long If LB = 0 Then x = -1 'so cSDIDX will start with item 0 End If For i = LB To UB 'adding unique column 1 items A etc. If cSD1.Exists(vArray(i, lGroupColumn)) = False Then cSD1.Add vArray(i, lGroupColumn), vArray(i, lGroupColumn) 'to keep track of the position of the first unique column 1 items x = x + 1 cSDIDX.Add vArray(i, lGroupColumn), x End If 'adding unique rows A,H1 etc. If cSD2.Exists(vArray(i, lGroupColumn) & vArray(i, lFindColumn)) = False Then cSD2.Add vArray(i, lGroupColumn) & vArray(i, lFindColumn), vArray(i, lGroupColumn) 'to keep track of the number of column 2 items per unique column 1 item lIDX = cSDIDX.Item(vArray(i, lGroupColumn)) arrColumns(lIDX) = arrColumns(lIDX) + 1 If arrColumns(lIDX) lCols Then lCols = arrColumns(lIDX) End If End If 'to keep track of unique column 2 items If cSD3.Exists(vArray(i, lGroupColumn) & vArray(i, lFindColumn)) = False Then cSD3.Add vArray(i, lGroupColumn) & vArray(i, lFindColumn), vArray(i, lFindColumn) End If Next i On Error GoTo 0 ReDim arrResult(LB To cSD1.Count - (1 - LB), LB2 To lCols + 1 - (1 - LB2)) 'fill in the unique (per column 1 item) column 2 items For i = 1 To cSD2.Count '+ LB is needed as IndexByKey is 0-based lIDX = cSDIDX.IndexByKey(cSD2.ItemByIndex(i - 1)) + LB arrResult(lIDX, LB2) = arrResult(lIDX, LB2) + 1 arrResult(lIDX, arrResult(lIDX, LB2) + 1 - (1 - LB2)) = cSD3.ItemByIndex(i - 1) Next i 'fill in the unique column 1 items For i = 1 To cSD1.Count arrResult(i - (1 - LB), lGroupColumn) = cSD1.ItemByIndex(i - 1) Next i GroupUniqueArrayElementsSorted = arrResult End Function RBS "lsy" wrote in message ... name lx A H1 A H1 A H2 A H3 B H1 B H2 name lx A H1£¬H2£¬H3 B H1£¬H2 thx excel2003 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Help with this marco | Excel Programming | |||
Creating a Hyperlink within a marco | Excel Programming | |||
Need help creating a variable size printarea marco. | Excel Programming | |||
help me with this marco | Excel Programming | |||
marco | Excel Programming |