P
pfbaro
Hi,
I already posted on message about a year ago on the same topic:
see url:
https://groups.google.com/forum/?hl...ic.excel.programming/g0sDHb2ovNI/pPHGA4KWHy0J
At that time of the thread in the link, I was learning from basic level Vbafor Excel. Since them, I think I improved and as a matter of fact, I want to see if what I have done is ok. Please read the instruction below as a few things have changed from the original post in the link (colums have also to be taken into consideration):
explanation ---o---
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. Nothing should be deleted from the data in the first set. Even ifone 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 data 1
B
C
F
2nd set:
col1 col2 col6 col7
A data 2 (row C and col5 are missing)
B
D
E
F
should result in
col1 col2 col5 col6 col7
A data 2 only (merger)
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 my code for this, I have to say it's far from working with large amount of data as I don't use extensively objects methods. If someone could show how this could be simplified, that's the purpose of my post, otherwise the code works properly (I only have 50 to 100 lines so I'm not lookingfor performance...however I would like to see a code that takes in consideration performance)
Thanks
---o---
my code
---o---
Sub A_IncorpNewRC4()
Dim wb As Workbook
Dim wsActif As Worksheet
Dim wsActif2 As Worksheet
Dim wsActifResult As Worksheet
Dim wsR As Worksheet
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set wb = ThisWorkbook
Set wsActif = wb.Worksheets("ActifJuin")
Set wsActif2 = wb.Worksheets("ActifJuil")
Set wsR = wb.Worksheets("Sheet3")
Set wsActifResult = wb.Worksheets("RESULTAT1")
wsActif.Rows(1).Copy wsActifResult.Range("A1")
'Range sort before array affect
SortRange2 wsActif
SortRange2 wsActif2
RetRowNbFor wsActif, wsActif2, wsActifResult
wsR.Select
wsActifResult.Range("A2:B24").Copy wsR.Cells(2, 6)
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set wb = Nothing
Set wsActif = Nothing
Set wsActif2 = Nothing
End Sub
Sub RetRowNbFor(ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet)
Dim wb As Workbook
Dim wsZ As Worksheet
Set wb = ThisWorkbook
Set wsZ = wb.Worksheets("Sheet3")
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)
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
---o---end code
If you feel you can help by providing a code of your own, likely shorter since there might be methods that would spare me a couple of lines from above..
Pascal Baro
(e-mail address removed)
I already posted on message about a year ago on the same topic:
see url:
https://groups.google.com/forum/?hl...ic.excel.programming/g0sDHb2ovNI/pPHGA4KWHy0J
At that time of the thread in the link, I was learning from basic level Vbafor Excel. Since them, I think I improved and as a matter of fact, I want to see if what I have done is ok. Please read the instruction below as a few things have changed from the original post in the link (colums have also to be taken into consideration):
explanation ---o---
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. Nothing should be deleted from the data in the first set. Even ifone 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 data 1
B
C
F
2nd set:
col1 col2 col6 col7
A data 2 (row C and col5 are missing)
B
D
E
F
should result in
col1 col2 col5 col6 col7
A data 2 only (merger)
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 my code for this, I have to say it's far from working with large amount of data as I don't use extensively objects methods. If someone could show how this could be simplified, that's the purpose of my post, otherwise the code works properly (I only have 50 to 100 lines so I'm not lookingfor performance...however I would like to see a code that takes in consideration performance)
Thanks
---o---
my code
---o---
Sub A_IncorpNewRC4()
Dim wb As Workbook
Dim wsActif As Worksheet
Dim wsActif2 As Worksheet
Dim wsActifResult As Worksheet
Dim wsR As Worksheet
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set wb = ThisWorkbook
Set wsActif = wb.Worksheets("ActifJuin")
Set wsActif2 = wb.Worksheets("ActifJuil")
Set wsR = wb.Worksheets("Sheet3")
Set wsActifResult = wb.Worksheets("RESULTAT1")
wsActif.Rows(1).Copy wsActifResult.Range("A1")
'Range sort before array affect
SortRange2 wsActif
SortRange2 wsActif2
RetRowNbFor wsActif, wsActif2, wsActifResult
wsR.Select
wsActifResult.Range("A2:B24").Copy wsR.Cells(2, 6)
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With
Set wb = Nothing
Set wsActif = Nothing
Set wsActif2 = Nothing
End Sub
Sub RetRowNbFor(ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet)
Dim wb As Workbook
Dim wsZ As Worksheet
Set wb = ThisWorkbook
Set wsZ = wb.Worksheets("Sheet3")
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)
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
---o---end code
If you feel you can help by providing a code of your own, likely shorter since there might be methods that would spare me a couple of lines from above..
Pascal Baro
(e-mail address removed)