Hi cyberspace,

I have spent quite some time trying to make this work but at this
point from adding many msgbox checks, using the watch window for
variables values everything seems coherent to me.

I have 2 columns with sorted identical and not identical numercial
values in both columns :

col.A col.B
251120 251130
251140 272505
251145 291101
272505 292100
272535
291130
292100

I need to align identical value and to place single value alone on
one
row just like below :

251120
251130
251140
251145
272505 272505
272535
291101
291130
292100 292100

Now with the vba code, I get this :

Option Explicit
Option Base 1

Public Sub RowMatching()

Dim wkb As Workbook
Dim wks As Worksheet
Set wkb = Workbooks("code_row_v2.xls")
Set wks = wkb.Worksheets("Sheet1")
Dim trouve As Boolean
Dim LigCol1 As Integer 'numéro de ligne pour la premiere colonne
Dim LigCol2 As Integer 'numéro de ligne pour la seconde colonne
Dim LastRow As Long
Dim tmp
Dim Numligne(256) As Long
Dim marchehaute As Integer
Dim marchebasse As Integer
Dim marche As Integer

wks.Cells(1, 1).Select
LastRow = 0
LigCol1 = 1
While wks.Cells(LigCol1, 1) < ""
LastRow = LastRow + 1
LigCol1 = LigCol1 + 1
Wend
LigCol1 = 1
wks.Cells(LigCol1, 1).Select

While LigCol1 <= LastRow '''MAIN LOOP

Numligne(LigCol1) = wks.Cells(LigCol1, 1)
'MsgBox wks.Cells(LigCol1, 1)

For LigCol2 = 1 To LastRow
If Numligne(LigCol1) = wks.Cells(LigCol2, 2) Then '2a-IF7
If LigCol2 < LigCol1 Then '3a-IF9
Cells(LigCol2, 2).Select
marchehaute = LigCol1 - LigCol2
marche = 1
While marche <= marchehaute
Selection.Insert shift:=xlDown
marche = marche + 1
Wend
ElseIf LigCol2 LigCol1 Then
Cells(LigCol1, 1).Select
marchebasse = LigCol2 - LigCol1
marche = 1
While marche <= marchebasse
Selection.Insert shift:=xlDown
marche = marche + 1
LastRow = LastRow + 1
Wend
End If '3a-IF9
End If '2a-IF7
Next LigCol2
LigCol1 = LigCol1 + 1

Wend '''END MAIN LOOP

LigCol1 = 1
wks.Cells(LigCol1, 1).Select

''SECONDARY LOOP TO INSERT ROW FOR REMAINING NON IDENTICAL VALUES
FOUND ONTO SAME ROWS

For LigCol1 = 1 To LastRow '

MsgBox wks.Cells(LigCol1, 1) & " - " & wks.Cells(LigCol1, 2)
If Not IsEmpty(wks.Cells(LigCol1)) Then
If wks.Cells(LigCol1, 1).Value < wks.Cells(LigCol1, 2).Value
Then
Rows(LigCol1).Select
Selection.Insert shift:=xlDown
Cells(LigCol1 + 1, 1).Select
Selection.Cut
Cells(LigCol1, 1).Select
ActiveSheet.Paste
LastRow = LastRow + 1
End If
End If '2b-IF5

Next LigCol1 '''END SECONDARY LOOP

MsgBox LastRow

End Sub

Variable names are in french but it's easy : consider marche is
floor : marchebasse = lowerfloor, marchehaute = upperfloor... in fact
marche means step but steps has many meaning in english and is a vba
keyword as well..., here it would
be stairway.

Ok, this is what I get when i run the code from above :

251120
251130
251140
251145
272505 272505
272535 291101
291130
292100 292100

Although, the switch is completed for values 251120 and 251130
initialy on the same row, they are now on 2 distinct rows as stated
in For LigCol1 = 1 To LastRow loop .

But when it comes to values 272535 and 291101, no new rows is added
as
it should for two different values on the same row. msgbox even show
the loop is going though these values as with 251120 and 251130
Could you point where I am missing something?

I would very much appreciate to understand why it's not working as
intended as it seems coherent from the msgbox checks when running it.
I think something is messing in the secondary loop block code.

Thanks,
Cyberuser

I tried this using your values and came up with the following result:

251120
251130
251140
251145
272505 272505
272535
291101
291130
292100 292100

The code...

Sub AlignLikeRows()
Dim rng1 As Range, rng2 As Range, c As Range, c1 As Range, c2 As
Range
Dim v As Variant

Set rng1 = Range("A:A"): Set rng2 = Range("B:B")
rng1.Sort key1:=rng1.Cells(1), order1:=xlAscending
rng2.Sort key1:=rng2.Cells(1), order1:=xlAscending

For Each c In rng2
If Not IsEmpty(c) Then
If Not c.Value = c.Offset(, -1).Value And _
Not c.Offset(, -1) = "" Then
If Not c.Value = v Then
v = c.Value: c = ""
Set c2 = rng1.Find(what:=v, _
after:=rng1.Cells(1), _
lookat:=xlWhole)
If Not c2 Is Nothing Then
c2.Offset(, 1).Insert shift:=xlDown
c2.Offset(, 1).Value = v
Else '//not found so insert it where it belongs
For Each c1 In rng1
If c1 v Then
c1.EntireRow.Insert: c1.Offset(-1, 1) = v: Exit For
End If
Next
End If
End If
End If
End If
Next
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

On Mar 12, 3:58*pm, bpascal123 wrote:
I have 2 columns with sorted identical and not identical
numercial values in both columns :
col.A * * * col.B
251120 *251130
251140 *272505
251145 *291101
272505 *292100
[....]
I need to align identical value and to place single value
alone on one row just like below :
251120
* * * * * * * * 251130
251140
251145
272505 *272505

The following macro avoids Insert Shift:=xlDown, which can be very
inefficient.

I assume that there is no useful data below the contiguous data in
columns A and B which are to aligned as you specify.

If that assumption is incorrect, it is easy to add the Insert
Shift:=xlDown. But in that case, it would better to change the
implementation fill the aligned data into local arrays first and to
make other prudent design changes.

Let me know if the design changes are needed.

-----

Option Explicit

Sub doit()
Dim ra As Range, rb As Range, cola, colb
Dim na As Long, nb As Long
Dim minrow As Long, maxrow As Long
Dim r As Long, ia As Long, ib As Long
Dim oldcalc

oldcalc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

#If 0 Then
'** if you wish, delete #if and #endif lines
Workbooks("code_row_v2.xls").Worksheets("Sheet1"). Active
#End If

'** ra and rb are first nonblank data to last
'** contiguous nonblank data in each column.
Set ra = Range(Range("a1").End(xlDown), _
Range("a1").End(xlDown).End(xlDown))
Set rb = Range(Range("b1").End(xlDown), _
Range("b1").End(xlDown).End(xlDown))

'** copy ra into cola(1 to na,1 to 1)
'** and rb into colb(1 to nb,1 to 1)
cola = ra: na = ra.Count
colb = rb: nb = rb.Count

'** assume ra and rb are each sorted
ReDim res(1 To na + nb, 1 To 3)
minrow = IIf(ra.Row <= rb.Row, ra.Row, rb.Row)
r = minrow - 1
ia = 1: ib = 1
Do
r = r + 1
If cola(ia, 1) < colb(ib, 1) Then
res(r, 1) = cola(ia, 1): ia = ia + 1
ElseIf cola(ia, 1) colb(ib, 1) Then
res(r, 3) = colb(ib, 1): ib = ib + 1
Else
res(r, 1) = cola(ia, 1): ia = ia + 1
res(r, 2) = colb(ib, 1): ib = ib + 1
End If
Loop Until ia na Or ib nb
For ia = ia To na
r = r + 1: res(r, 1) = cola(ia, 1)
Next
For ib = ib To nb
r = r + 1: res(r, 3) = colb(ib, 1)
Next

'** clear maximum number of rows in 3 columns.
'** assume there is no useful data below ra and rb
maxrow = minrow + r - 1
If maxrow < ra.Row + na Then maxrow = ra.Row + na
If maxrow < rb.Row + nb Then maxrow = rb.Row + nb
Range(Cells(minrow, 1), Cells(maxrow, 3)).ClearContents
Range(Cells(minrow, 1), Cells(minrow + r - 1, 3)) = res
Application.EnableEvents = True
Application.Calculation = oldcalc
Application.ScreenUpdating = True
End Sub

Errata....

On Mar 12, 8:57*pm, joeu2004 wrote:
If that assumption is incorrect, it is easy to add the Insert
Shift:=xlDown. *But in that case, it would better to change
the implementation fill the aligned data into local arrays
first and to make other prudent design changes.

Actually, I already made the change to use local arrays; more
efficient anyway. The needed adjustment is the appropriate Insert
Shift:=xlDown operations.

Let me know if you want that.

This macro appears to do what you asked for...

Sub AlignColumnData()
Dim M As Long, D As Long, Rw As Long, Main As Variant, Data As Variant
With WorksheetFunction
Main = .Transpose(Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row))
Data = .Transpose(Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row))
End With
Range("A:B").Clear
M = LBound(Main)
D = LBound(Data)
Do While M + D <= UBound(Main) + UBound(Data)
Rw = Rw + 1
If Main(M) = Data(D) Then
Range("A" & Rw).Resize(1, 2).Value = Main(M)
M = M + 1
D = D + 1
ElseIf Main(M) < Data(D) Then
Range("A" & Rw).Value = Main(M)
M = M + 1
Else
Range("A" & Rw).Offset(0, 1).Value = Data(D)
D = D + 1
End If
Loop
End Sub

Rick Rothstein (MVP - Excel)

I should point out that my previously posted code requires the two columns
to be sorted (as the OP indicated they were). If they are not sorted (and
you do not want to do that step yourself), then you could use this macro
instead of the one I posted earlier (it takes care of the sorting for
you)...

Sub AlignColumnData()
Dim M As Long, D As Long, Rw As Long, Main As Variant, Data As Variant
Columns("A").Sort Range("A1"), xlAscending
Columns("B").Sort Range("B1"), xlAscending
With WorksheetFunction
Main = .Transpose(Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row))
Data = .Transpose(Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row))
End With
Range("A:B").Clear
M = LBound(Main)
D = LBound(Data)
Do While M + D <= UBound(Main) + UBound(Data)
Rw = Rw + 1
If Main(M) = Data(D) Then
Range("A" & Rw).Resize(1, 2).Value = Main(M)
M = M + 1
D = D + 1
ElseIf Main(M) < Data(D) Then
Range("A" & Rw).Value = Main(M)
M = M + 1
Else
Range("A" & Rw).Offset(0, 1).Value = Data(D)
D = D + 1
End If
Loop
End Sub

Rick Rothstein (MVP - Excel)

Here are slightly shorter versions of my code, one assuming the data in both
columns are in sorted order before the macro is run and the other allowing
the data to be sorted or not sorted...

'===================================
' Data Pre-sorted
'===================================
Sub AlignColumnData()
Dim M As Long, D As Long, Rw As Long, TempM As Long, Main, Data
With WorksheetFunction
Main = .Transpose(Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row))
Data = .Transpose(Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row))
Range("A:B").Clear
M = LBound(Main)
D = LBound(Data)
Do While M + D <= UBound(Main) + UBound(Data)
Rw = Rw + 1
Range("A" & Rw).Offset(0, -(Main(M) Data(D))).Resize(1, _
1 - (Main(M) = Data(D))) = .Min(Main(M), Data(D))
TempM = Main(M)
M = M - (Main(M) <= Data(D))
D = D - (TempM = Data(D))
Loop
End With
End Sub

'===================================
' Data Not Necessarily Sorted
'===================================
Sub AlignColumnData()
Dim M As Long, D As Long, Rw As Long, TempM As Long, Main, Data
Columns("A").Sort Range("A1"), xlAscending
Columns("B").Sort Range("B1"), xlAscending
With WorksheetFunction
Main = .Transpose(Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row))
Data = .Transpose(Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row))
Range("A:B").Clear
M = LBound(Main)
D = LBound(Data)
Do While M + D <= UBound(Main) + UBound(Data)
Rw = Rw + 1
Range("A" & Rw).Offset(0, -(Main(M) Data(D))).Resize(1, _
1 - (Main(M) = Data(D))) = .Min(Main(M), Data(D))
TempM = Main(M)
M = M - (Main(M) <= Data(D))
D = D - (TempM = Data(D))
Loop
End With
End Sub


Rick Rothstein (MVP - Excel)

Hi,

Thanks for your code.
I went through part of it not without difficulties. I should have told
first it's my first vba code from a personal task...and i'm not really
aware of vba objects that's why most code here is shorter than mine
and seems a lot more efficient. I'll try to read them further.
However, i find it easier to learn vba code while implementing a
personal task rather than from reading lines of code. Any further
advice for this feeling?

From what I can understand, I should use less the select method and
use more the offset property. It would quite change the design of the
code and programming habits (I have a 2-3 years programming experience
with non-object languages). Would learning C++ help to find vba
easier?

So, I have found a fix on the secondary loop that makes the code work,
see 'A
However, I don't know if it's as rock solid as what I can find from
average and experts codes. Whatsoever, i know it's not efficient. I
understand I should get some training with vba arrays and the job done
in vba array.

Are vba arrays treated in segment data or heap or stack memory. Are
variant and fixed size arrays treated the same?

I have also replaced the :
select and selection.insert shift:=xldown
with :
Cells(LigCol1, 1).EntireRow.Insert shift:=xlDown in the secondary
loop.

Below is the code:


Option Explicit
Option Base 1


Public Sub RowMatching()

Dim wkb As Workbook
Dim wks As Worksheet
Set wkb = Workbooks("code_row_v2.xls")
Set wks = wkb.Worksheets("Sheet1")

Dim trouve As Boolean

Dim LigCol1 As Integer 'numéro de ligne pour la premiere colonne
Dim LigCol2 As Integer 'numéro de ligne pour la seconde colonne
Dim LastRow As Long
Dim tmp
Dim Numligne(256) As Long
Dim marchehaute As Integer
Dim marchebasse As Integer
Dim marche As Integer

wks.Cells(1, 1).Select

LastRow = 0
LigCol1 = 1
While wks.Cells(LigCol1, 1) < ""
LastRow = LastRow + 1
LigCol1 = LigCol1 + 1
Wend

LigCol1 = 1
wks.Cells(LigCol1, 1).Select
While LigCol1 <= LastRow '''MAIN LOOP
Numligne(LigCol1) = wks.Cells(LigCol1, 1)
'MsgBox wks.Cells(LigCol1, 1)
For LigCol2 = 1 To LastRow

If Numligne(LigCol1) = wks.Cells(LigCol2, 2) Then '2a-IF7

If LigCol2 < LigCol1 Then '3a-IF9
Cells(LigCol2, 2).Select
marchehaute = LigCol1 - LigCol2
marche = 1
While marche <= marchehaute
Selection.Insert shift:=xlDown
marche = marche + 1
Wend

ElseIf LigCol2 LigCol1 Then
Cells(LigCol1, 1).Select
marchebasse = LigCol2 - LigCol1
marche = 1
While marche <= marchebasse
Selection.Insert shift:=xlDown
marche = marche + 1
LastRow = LastRow + 1
Wend

End If '3a-IF9

End If '2a-IF7

Next LigCol2

LigCol1 = LigCol1 + 1

Wend '''END OF MAIN LOOP

''' SECONDARY LOOP

LigCol1 = 1
wks.Cells(LigCol1, 1).Select
For LigCol1 = 1 To LastRow
'MsgBox wks.Cells(LigCol1, 1) & " - " & wks.Cells(LigCol1, 2)

If Not IsEmpty(wks.Cells(LigCol1, 1)) Then '2b-IF5
If Not IsEmpty(wks.Cells(LigCol1, 2))
Then 'A
If wks.Cells(LigCol1, 1).Value < wks.Cells(LigCol1, 2).Value
Then
Cells(LigCol1, 1).EntireRow.Insert shift:=xlDown
Cells(LigCol1 + 1, 1).Select
Selection.Cut
Cells(LigCol1, 1).Select
ActiveSheet.Paste
LastRow = LastRow + 1
End If
End If
End If '2b-IF5
'Range("B9").EntireRow.Insert shift:=xlDown
Next LigCol1

''' END OF SECONDARY LOOP

'MsgBox LastRow

End Sub


-°-
thanks

cm comments in-line

"bpascal123" wrote in message
...
Hi,

Thanks for your code.
I went through part of it not without difficulties. I should have told
first it's my first vba code from a personal task...and i'm not really
aware of vba objects that's why most code here is shorter than mine
and seems a lot more efficient. I'll try to read them further.
However, i find it easier to learn vba code while implementing a
personal task rather than from reading lines of code. Any further
advice for this feeling?

cmI saw several different solutions proposed, each using a slightly
different approach. My advice would be to invest the time to understand
exactly how and why each proposal works. Rather than "reading lines of
code", paste them into a code module and use a combination of the
debugger and <F1 (the built-in help) to discover that understanding. I
found that when I began using the debugger's Locals Window my level of
understanding of vba objects increased dramatically. [VBE Menu: View |
Locals Window ]

From what I can understand, I should use less the select method and
use more the offset property.

cm It's not so much using offset instead of select that gains
efficiency. As I understand it, you gain the most efficiency when you
write code that does not update the display- .Select and .Activate do
update the display. In code you can read or modify a range directly
without ever selecting it. I was going to suggest that you read the
entire range into an array, manipulate the array within vba, then write
the updated array back to the worksheet as a method to increase
efficiency (only "touch" the worksheet 6 or 7 times total, rather than
"touching" it for each cell as you iterate through the data) -- but
never did because that has already been posted. So: the efficiency gains
come from reducing manipulation of the display (and, I think, from
reducing the number of "touches" on the worksheet.)

It would quite change the design of the
code and programming habits (I have a 2-3 years programming experience
with non-object languages). Would learning C++ help to find vba
easier?

cm I cannot speak to that; I have no C experinece at all.

So, I have found a fix on the secondary loop that makes the code work,
see 'A
However, I don't know if it's as rock solid as what I can find from
average and experts codes. Whatsoever, i know it's not efficient. I
understand I should get some training with vba arrays and the job done
in vba array.

Are vba arrays treated in segment data or heap or stack memory. Are
variant and fixed size arrays treated the same?

cm I suggest that you read the help regarding arrays. It may help
answer your question. A variable of type variant can hold an array --
and that is different from an array variable delared with a Dim
ArrayName() statement. My suggestion was going to use three arrays -
one fixed array each for your column 1 and column 2 data, and a variable
two dimensional array that "grew" (using ReDim) each iteration. What I
don't know is the efficiency cost of using redim to extend an array each
iteration (vs) using a fixed array. The trouble with using a fixed
array in this case is that you do not know in advance how many rows will
be required in the final result.

[ snip ]

cm A couple comments regarding your original code:

I noticed that in some places you used [ wks.cells(...) ] and in other
placed you left off the wks qualifier [ cells(...) ]. Dangerous
practice -- in fact, I noticed it when I (inadvertantly) created a test
environment where the default worksheet object (the one referenced by
Cells without the preceeding object qualifier) was different by the time
the [ Cells(...) ] was executed than when [Set wks = Activesheet ] was
executed which caused erroneous results.

Also, as a matter of personal preference, I much prefer using
debug.print than msgbox while testing code. [ View | Immediate Window ]
to see what debug.print has printed. In fact, I use a combination of
debug.print, setting breakpoints, single-stepping through code, Locals
Window and the screen-tip of variable contents when hovering over a
variable while execution is stopped during a breakpoint.

Welcome to learning VBA! You have come to an excellent place to ask
questions and receive good answers. Come back often just to lurk ---
you will learn much from the solutions and answers posted here.

--
Clif McIrvin

(clare reads his mail with moe, nomail feeds the bit bucket :-)

--
Clif McIrvin

(clare reads his mail with moe, nomail feeds the bit bucket :-)

Hi,

I take these advices seriously. I'm currently having a difficult time
dealing with range of cells instead of one by one cells... The code in
this discussion helps to understand handling data into arrays
variables. I haven't made it to that level and it seems I need to
practice on specific tasks. I hope to get trought this first step and
not feel discouraged :( ):

Thx
Pascal

*** DO NOT USE THE CODE I POST PREVIOUSLY ***

DAMN! The code I posted does not always work correctly.

I'm working on alternative code new.

Rick Rothstein (MVP - Excel)

Not as compact as I still imagine is possible, but here is working code
(until I can find a more compact version)...

Sub AlignColumnData()
Dim X As Long, Lngth As Long, Data As Variant, Cell As Range
Data = WorksheetFunction.Transpose(Range("B1:B" & Cells(Rows.Count,
"B").End(xlUp).Row))
With Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Clear
End With
Columns("A").Sort Range("A1"), xlAscending
For X = 2 To Cells(Rows.Count, "A").End(xlUp).Row
With Cells(X, "A")
If .Value = Cells(X - 1, "A").Value Then
.Offset(-1, 1).Value = Cells(X, "A").Value
.Clear
End If
End With
Next
Columns("A").SpecialCells(xlCellTypeBlanks).Entire Row.Delete
For X = LBound(Data) To UBound(Data)
With Columns("A").Find(Data(X), LookAt:=xlWhole)
Lngth = Len(.Offset(0, 1).Value)
If Lngth = 0 Then
.Copy .Offset(0, 1)
.Clear
End If
End With
Next
End Sub

Rick Rothstein (MVP - Excel)

Rick - I'm studying your code with interest -- and have a couple "Why"
questions.

"Rick Rothstein" wrote in message
...
Not as compact as I still imagine is possible, but here is working
code (until I can find a more compact version)...

Sub AlignColumnData()
Dim X As Long, Lngth As Long, Data As Variant, Cell As Range
Data = WorksheetFunction.Transpose(Range("B1:B" & Cells(Rows.Count,
"B").End(xlUp).Row))
With Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)

Here you repeated [ Cells(Rows.Count, "B").End(xlUp).Row) ] on two
lines.

Is that actually faster than putting the result into a Long varaible?

[...]
Lngth = Len(.Offset(0, 1).Value)
If Lngth = 0 Then

and here, you use the long variable, but I'm mystified as to why.
Wouldn't it work to put the [ Len(.Offset(0, 1).Value) ] directly in the
If statement?

Perhaps you have a link to direct me to additional reading?


--
Clif McIrvin

(clare reads his mail with moe, nomail feeds the bit bucket :-)

Rick - I'm studying your code with interest -- and have a
couple "Why" questions.

I will be away from my computer for awhile, but feel free to ask away and
I'll be happy to respond when I return.

Rick Rothstein (MVP - Excel)




"Clif McIrvin" wrote in message
...

Rick - I'm studying your code with interest -- and have a couple "Why"
questions.

"Rick Rothstein" wrote in message
...
Not as compact as I still imagine is possible, but here is working code
(until I can find a more compact version)...

Sub AlignColumnData()
Dim X As Long, Lngth As Long, Data As Variant, Cell As Range
Data = WorksheetFunction.Transpose(Range("B1:B" & Cells(Rows.Count,
"B").End(xlUp).Row))
With Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)

Here you repeated [ Cells(Rows.Count, "B").End(xlUp).Row) ] on two
lines.

Is that actually faster than putting the result into a Long varaible?

[...]
Lngth = Len(.Offset(0, 1).Value)
If Lngth = 0 Then

and here, you use the long variable, but I'm mystified as to why.
Wouldn't it work to put the [ Len(.Offset(0, 1).Value) ] directly in the
If statement?

Perhaps you have a link to direct me to additional reading?


--
Clif McIrvin

(clare reads his mail with moe, nomail feeds the bit bucket :-)

Here is cleaned up code that resulted from two excellent observations by
Clif McIrvin (thanks Clif)....

Sub AlignColumnData()
Dim X As Long, Data As Variant, Cell As Range
With Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Data = WorksheetFunction.Transpose(.Cells)
.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Clear
End With
Columns("A").Sort Range("A1"), xlAscending
For X = 2 To Cells(Rows.Count, "A").End(xlUp).Row
With Cells(X, "A")
If .Value = Cells(X - 1, "A").Value Then
.Offset(-1, 1).Value = Cells(X, "A").Value
.Clear
End If
End With
Next
Columns("A").SpecialCells(xlCellTypeBlanks).Entire Row.Delete
For X = LBound(Data) To UBound(Data)
With Columns("A").Find(Data(X), LookAt:=xlWhole)
If Len(.Offset(0, 1).Value) = 0 Then
.Copy .Offset(0, 1)
.Clear
End If
End With
Next
End Sub

Rick Rothstein (MVP - Excel)

Really nice, Rick! You continue to shine...

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup! comp.lang.basic.visual.misc

On Mar 12, 11:58*pm, bpascal123 wrote:
Hi cyberspace,

I have spent quite some time trying to make this work but at this
point from *adding many msgbox checks, using the watch window for
variables values everything seems coherent *to me.

I have 2 columns with sorted identical and not identical numercial
values in both columns :

col.A * * * col.B
251120 *251130
251140 *272505
251145 *291101
272505 *292100
272535
291130
292100

I need to align identical value and to place single value alone on
one
row just like below :

251120
* * * * * * * * 251130
251140
251145
272505 *272505
272535
* * * * * * * * 291101
291130
292100 *292100

Now with the vba code, I get this :

Option Explicit
Option Base 1

Public Sub RowMatching()

* Dim wkb As Workbook
* Dim wks As Worksheet
* Set wkb = Workbooks("code_row_v2.xls")
* Set wks = wkb.Worksheets("Sheet1")
* Dim trouve As Boolean
* Dim LigCol1 As Integer *'numéro de ligne pour la premiere colonne
* Dim LigCol2 As Integer *'numéro de ligne pour la seconde colonne
* Dim LastRow As Long
* Dim tmp
* Dim Numligne(256) As Long
* Dim marchehaute As Integer
* Dim marchebasse As Integer
* Dim marche As Integer

* wks.Cells(1, 1).Select
* LastRow = 0
* LigCol1 = 1
* While wks.Cells(LigCol1, 1) < ""
* * LastRow = LastRow + 1
* * LigCol1 = LigCol1 + 1
* Wend
* LigCol1 = 1
* wks.Cells(LigCol1, 1).Select

* While LigCol1 <= LastRow *'''MAIN LOOP

* * Numligne(LigCol1) = wks.Cells(LigCol1, 1)
* * 'MsgBox wks.Cells(LigCol1, 1)

* * For LigCol2 = 1 To LastRow
* * * If Numligne(LigCol1) = wks.Cells(LigCol2, 2) Then '2a-IF7
* * * * If LigCol2 < LigCol1 Then * * * * * * * * * * * '3a-IF9
* * * * * Cells(LigCol2, 2).Select
* * * * * marchehaute = LigCol1 - LigCol2
* * * * * marche = 1
* * * * * While marche <= marchehaute
* * * * * * Selection.Insert shift:=xlDown
* * * * * * marche = marche + 1
* * * * * Wend
* * * * ElseIf LigCol2 LigCol1 Then
* * * * * Cells(LigCol1, 1).Select
* * * * * marchebasse = LigCol2 - LigCol1
* * * * * marche = 1
* * * * * While marche <= marchebasse
* * * * * * Selection.Insert shift:=xlDown
* * * * * * marche = marche + 1
* * * * * * LastRow = LastRow + 1
* * * * * Wend
* * * * End If * * * * * * * * * * * * * * * * * * * * *'3a-IF9
* * * End If * * * * * * * * * * * * * * * * * * * * * *'2a-IF7
* * Next LigCol2
* * LigCol1 = LigCol1 + 1

* Wend '''END MAIN LOOP

* LigCol1 = 1
* wks.Cells(LigCol1, 1).Select

''SECONDARY LOOP TO INSERT ROW FOR REMAINING NON IDENTICAL VALUES
FOUND ONTO SAME ROWS

* For LigCol1 = 1 To LastRow '

* * MsgBox wks.Cells(LigCol1, 1) & " - " & wks.Cells(LigCol1, 2)
* * If Not IsEmpty(wks.Cells(LigCol1)) Then
* * * If wks.Cells(LigCol1, 1).Value < wks.Cells(LigCol1, 2).Value
Then
* * * * Rows(LigCol1).Select
* * * * Selection.Insert shift:=xlDown
* * * * Cells(LigCol1 + 1, 1).Select
* * * * Selection.Cut
* * * * Cells(LigCol1, 1).Select
* * * * ActiveSheet.Paste
* * * * LastRow = LastRow + 1
* * * End If
* * End If * * * * * * * * * * * * * * * * * * * * * * * * * '2b-IF5

* Next LigCol1 * '''END SECONDARY LOOP

* MsgBox LastRow

End Sub

Variable names are in french but it's easy : consider marche is
floor : marchebasse = lowerfloor, marchehaute = upperfloor... in fact
marche means step but steps has many meaning in english and is a vba
keyword as well..., here it would
be stairway.

Ok, this is what I get when i run the code from above :

251120
* * * * * * * * 251130
251140
251145
272505 *272505
272535 *291101
291130
292100 *292100

Although, the switch is completed for values 251120 and 251130
initialy on the same row, they are now on 2 distinct rows as stated
in *For LigCol1 = 1 To LastRow loop .

But when it comes to values 272535 and 291101, no new rows is added
as
it should for two different values on the same row. msgbox even show
the loop is going though these values as with 251120 and 251130
Could you point where I am missing something?

I would very much appreciate to understand why it's not working as
intended as it seems coherent from the msgbox checks when running it.
I think something is messing in the secondary loop block code.

Thanks,
Cyberuser

From Phillip London UK

This works for me

Sub DoData()
Dim vRng1, vRng2, vEvaluate As Variant
Dim NoMa As Long
Dim Ma As Long
Dim TempRng As Range

vRng1 = Sheet1.Range("A1:A7").Value 'change range as required
vRng2 = Sheet1.Range("B1:B4").Value ''change range as required
Range("B:B").Clear

For z = LBound(vRng2) To UBound(vRng2)
vEvaluate = Application.Evaluate("IF(ISNA(MATCH(" & CLng(vRng2(z,
1))& ",A:A,0)),1,0)")
If vEvaluate = 1 Then
NoMa = Application.Evaluate("Match(" & CLng(vRng2(z, 1)) &
",A:A,1)")
Set TempRng = Range("A1").Offset(NoMa, 0)
TempRng.EntireRow.Insert
TempRng.Offset(-1, 1).Value = CLng(vRng2(z, 1))
Else
Ma = Application.Evaluate("MATCH(" & CLng(vRng2(z, 1)) &
",A:A,0)")
Range("B1").Offset(Ma - 1, 0).Value = CLng(vRng2(z, 1))
End If
Next
End Sub

Hi there,

This old discussion was tremendous so I feel like reactivating it for those still alive in this cyberspace.

Now there is another constraint, I'll start to explain the whole thing, if you read the first post, although the explanation is different, the problem is the same with as I said one more constraint: columns. Initially only rows had to be sorted and merged.

So the problem again:

I have a task that I can achieve up to one point using vlookup but afterwards I need to manually add rows or columns to update the data with a new set of data. It is understood the from the first set nothing should be deleted.. Even if one row is empty from the first set is not present in the second set of data, it should remain as an empty data row (but still with its identifier).

For example:

1st set
col1 col2 col5 col6
A
B
C
F

2nd set
col1 col2 col6 col7
A
B
D
F
E

should result in

col1 col2 col5 col6 col7
A
B
C
D
E
F

In the result, C is an empty row as it's not in the second set but must still be present with the letter C but without any data
Col5 will be empty as well as it's only present in the first set.

Please find a workbook with the first set of data in one sheet, the second set in another and the expected result from it.

Actually, I have coded it (it's currently the paramount of my vba algorithm level - very basic, as you can see i don't use much objects and collections. This is the reason I'm looking for help because with my way of coding this, with more than 1000 rows my code is totally inefficient. My goal is to make this task time-efficient although as i said i don't really need it.

link to the file:
http://www.sendspace.com/file/p0tp3l

my code if you can go through it without the file
---

Public optionBleuVert As Integer

Sub B_SortFor()

Dim wb As Workbook
Dim wsMPrec1 As Worksheet
Dim wsMCour2 As Worksheet
Dim wsMCour100 As Worksheet
Dim ws As Worksheet

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With

Set wb = ThisWorkbook
Set ws = wb.Worksheets("GLOBAL100")

If ws.Cells(13, 9).Value = "actif" Then
Set wsMPrec1 = wb.Worksheets("actifM0")
Set wsMCour2 = wb.Worksheets("actifM1")
Set wsMCour100 = wb.Worksheets("actifM10")
ElseIf ws.Cells(13, 9).Value = "passif" Then
Set wsMPrec1 = wb.Worksheets("passifM0")
Set wsMCour2 = wb.Worksheets("passifM1")
Set wsMCour100 = wb.Worksheets("passifM10")
Else
MsgBox "Veuillez clarifier votre choix, fin"
Exit Sub
End If

wsMCour2.Rows(1).Copy wsMCour100.Range("A1")

'Range sort before array affect
SortRange2 wsMPrec1
SortRange2 wsMCour2

RetRowNbFor wsMPrec1, wsMCour2, wsMCour100

wsMCour100.Select

Call DisplayNewAgences

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With

Set wb = Nothing
Set wsMPrec1 = Nothing
Set wsMCour2 = Nothing
Set wsMCour100 = Nothing

End Sub

Sub RetRowNbFor(ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet)

Dim rM As Range
Dim lastr1 As Long, lastr2 As Long
Dim lastr3 As Long
Dim lastc1 As Long, lastc2 As Long
Dim lastr1b As Long, lastr2b As Long

Dim i As Long, j As Long, k As Long
Dim z As Long

Dim boo As Long
Dim Vjuin As Long, Vjuill As Long
Dim VjuinB As Long, VjuillB As Long
Dim Fjuill As Long
Dim bplus As Long, bmoins As Long
Dim r As Range

boo = 0
lastr1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
lastc1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
lastr2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
lastc2 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column
k = 2

boo = 0
For i = lastr1 To 2 Step -1
boo = 0
If IsEmpty(ws1.Cells(i, 1).Value) = False Then

Vjuin = ws1.Cells(i, 1).Value

For j = lastr2 To 2 Step -1

If IsEmpty(ws2.Cells(j, 1).Value) = False Then

Vjuill = ws2.Cells(j, 1).Value

If Vjuill < Vjuin Then
boo = 3
ElseIf Vjuill = Vjuin Then
boo = 2
Exit For
Else
boo = 0
End If

End If

Next j

If boo = 3 Then
ws3.Cells(k, 1).Value = Vjuin
ws3.Rows(k).Insert
ElseIf boo = 2 Then
Set rM = ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, lastc2))
rM.Copy ws3.Cells(k, 1)
ws3.Rows(k).Insert
End If

End If

Next i


For i = lastr2 To 2 Step -1
boo = 0
If IsEmpty(ws2.Cells(i, 1).Value) = False Then

Vjuill = ws2.Cells(i, 1).Value

For j = lastr1 To 2 Step -1
boo = 0
If IsEmpty(ws1.Cells(j, 1).Value) = False Then

Vjuin = ws1.Cells(j, 1).Value

If Vjuin < Vjuill Then
boo = 1
Else
Exit For
End If

End If

Next j

If boo = 1 Then

lastr3 = ws3.Cells(Rows.Count, 1).End(xlUp).Row

For j = lastr3 To 2 Step -1

Fjuill = ws3.Cells(j, 1).Value

If IsEmpty(ws3.Cells(j + 1, 1)) = False Then
bplus = ws3.Cells(j + 1, 1).Value
Else
bplus = 999999
End If
If j = 2 Then
bmoins = 0
Else
bmoins = ws3.Cells(j - 1, 1).Value
End If

If Vjuill < bplus And Vjuill bmoins Then

Set rM = ws2.Range(ws2.Cells(i, 1), ws2.Cells(i, lastc2))
ws3.Rows(j).Insert
rM.Copy ws3.Cells(j, 1)
ws3.Cells(j, 2).Interior.Color = 65535
Exit For
End If

Next j

End If
End If
Next i

ws3.Rows(2).Delete

End Sub


Sub SortRange2(ws As Worksheet)

Dim lastr As Long
Dim lastc As Long

lastr = ws.Cells(Rows.Count, 1).End(xlUp).Row
lastc = ws.Cells(1, Columns.Count).End(xlToLeft).Column

Dim r As Range
Set r = ws.Range(ws.Cells(1, 1), ws.Cells(lastr, lastc))

r.Sort key1:=ws.Columns(1), Header:=xlYes

End Sub

Sub optActif()

Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("GLOBAL100")

'optionBleuVert = "Actif"

ws.Cells(13, 9) = "actif"

End Sub


Sub optPassif()

Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("GLOBAL100")

ws.Cells(13, 9) = "passif"

End Sub


Pascal Baro