Wow, I like this VBA example quite a bit, the problem I provided was indeed simplistic and would need to be modified for my intended need. I'm fairly new at VBA and very much appreciate your skill and knowledge. I was wondering if an array was the way to go! Thank you Again!
On Feb 2, 3:51 am, siti Vi <villager.g...@gmail.com> wrote: > i think my code is too big (no a simple code) > but your refferred-table can be extended (add columns & / add rows) > without editing this code > > Sub Re_Arrange() > '----------------------------------------- > ' coded by: siti Vi <villager.g...@gmail.com> > ' jakarta, feb 1, 2011 > '----------------------------------------- > > '- declaring some variables... > Dim sItem As String ' consist of unique-items text separated by "\" > Dim dArr() As Variant ' dynamic array consist of Unique Item only > Dim TBLV() As Range ' dynamic array consist of each Vector / > ' [OneColumnTable] of Old table > Dim dTBL As Range ' the Old Table > Dim dNEW As Range ' the New Table > Dim xCell As Range ' each cell in Old Table > Dim i As Long, n As Long ' counters in some looping > Dim r As Long, c As Integer ' number of rows and columns of the Old Tbl > > '--assignments... > Set dTBL = Cells(1).CurrentRegion > c = dTBL.Columns.Count > r = dTBL.Rows.Count - 1 > Set dNEW = dTBL.Offset(1, c + 1) > Set dTBL = dTBL.Offset(1, 0).Resize(r, c) > dNEW.CurrentRegion.Clear > ' copying the header > dTBL.Offset(-1, 0).Resize(1, c).Copy dNEW(0, 1) > > '--assign some [OneColumnTable] in array > ' depends on the width of the Old Table > For i = 1 To c > ReDim Preserve TBLV(1 To i) > Set TBLV(i) = dTBL.Offset(0, i - 1).Resize(r, 1) > Next i > > '--items storred in an array (the unique item only) > For Each xCell In dTBL > If Len(xCell) > 0 Then > If InStr(1, sItem, xCell & "\") = 0 Then > sItem = sItem & xCell & "\" > n = n + 1 > ReDim Preserve dArr(1 To n) > dArr(n) = xCell.Value > End If > End If > Next xCell > > ' elemens in array is sorted ascending > dArr = SortArray(dArr) > > '-- reconstruct a new table based on Old table > With Application.WorksheetFunction > For i = 1 To UBound(dArr) > For n = 1 To c > If .CountIf(TBLV(n), dArr(i)) > 0 Then > dNEW(i, n) = dArr(i) > End If > Next n > Next i > End With > > End Sub > > Private Function SortArray(Ar) > ' bubble sorter (ascending order) > ' [one-dimension-array] to [one-dimension-array] > ' by siti Vi// jakarta, feb 1, 2011 > '------------------------------------------- > Dim a As Long, b As Long, c As Long, z As Long, t > z = UBound(Ar) > For a = LBound(Ar) To z - 1 > For b = z To (a + 1) Step -1 > c = b - 1 > If Ar(b) < Ar(c) Then > t = Ar(b): Ar(b) = Ar(c): Ar(c) = t > End If > Next b > Next a > SortArray = Ar > End Function > > thank you and best regards, > siti > > > > On Tue, Feb 1, 2011 at 11:18 AM, Nathan <protoc...@gmail.com> wrote: > > Hello all, > > I'm hoping you will have time to assist me understanding how to best > > tackle this comparison list shown at the following link. > > >https://docs.google.com/leaf?id=0B7Wrlvw2fV31ODliYzkwMWYtMzRhMi00OGU4... > > > I'm given a range similar to ("A1:B5") and need it to end up like > > range ("D1:E6"). Basically I have two list and need to sort out and > > add in blank cells to anything that does not match from either side. > > > Thank you in advance for any bits of VBA or places to start my seach. > > > > ctv_ReArrange for comparison.xls > 75KViewDownload- Hide quoted text - > > - Show quoted text - -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com 4. Learn VBA Macros at http://www.quickvba.blogspot.com 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com To post to this group, send email to excel-macros@googlegroups.com <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/discussexcel
