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
