Align cells with same value - vba almost working

G

GS

Clif McIrvin submitted this idea :
In Rick's code, he copies Col B below A, then sorts ...

Yes, I know. I added the sort to colB in case the data was not
contiguous. (As is the case after the code is run, then re-run)
 
C

Clif McIrvin

GS said:
Clif McIrvin submitted this idea :

Yes, I know. I added the sort to colB in case the data was not
contiguous. (As is the case after the code is run, then re-run)


Actually, Rick's code handled that just fine as posted ... I
accidentally did that while testing ... then studied his code some more
to see why it didn't fail <g>. His .copy didn't care that there was
dis-contiguous data, and after he sorted the result the data was all
contiguous again.
 
G

GS

Clif McIrvin has brought this to us :
Actually, Rick's code handled that just fine as posted ... I accidentally did
that while testing ... then studied his code some more to see why it didn't
fail <g>. His .copy didn't care that there was dis-contiguous data, and after
he sorted the result the data was all contiguous again.

This is only the case for colA. After the code runs, colB is no longer
contiguous and so re-running the code puts the empty cells into the
array, making the process longer than necessary. I put the line to sort
so this didn't happen.<g>
 
P

pascal baro

Hi there,

This old discussion was tremendous so I feel like reactivating it for thosestill 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 problemis 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 setof 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 algorithmlevel - 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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top