1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72
| Sub maj()
Dim wsCible As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim nbVal, Pfx, i As Integer
Dim tmpVal() As Variant
Dim lastRow As Integer
Dim rg As Range
Dim rgFind As Range
Set wsCible = ThisWorkbook.Worksheets("BD")
Set wbSource = Application.Workbooks("Class2.xls")
nbVal = 0
ReDim tmpVal(5, 0)
'--------------Récupération des données
For Each wsSource In wbSource.Worksheets
lastRow = wsSource.Range("B65000").End(xlUp).Row
For i = 2 To lastRow
If wsSource.Cells(i, "F").Value <> "" And IsNumeric(wsSource.Cells(i, "F").Value) Then
nbVal = nbVal + 1
ReDim Preserve tmpVal(5, nbVal - 1)
tmpVal(0, nbVal - 1) = wsSource.Name & wsSource.Cells(i, "A").Value
tmpVal(1, nbVal - 1) = Format(wsSource.Cells(i, "B").Value, "0##"" ""##"" ""##"" ""##")
tmpVal(2, nbVal - 1) = wsSource.Cells(i, "C").Value
tmpVal(3, nbVal - 1) = wsSource.Cells(i, "D").Value
tmpVal(4, nbVal - 1) = wsSource.Cells(i, "E").Value
tmpVal(5, nbVal - 1) = wsSource.Cells(i, "F").Value
End If
Next i
Next wsSource
'----------Remplissage du tableau
Set rg = wsCible.Range(wsCible.Range("A2"), wsCible.Range("A65000").End(xlUp))
For i = 1 To nbVal
Set rgFind = rg.Find(What:=tmpVal(1, i - 1), LookIn:=xlValues, LookAt:=xlPart)
If Not rgFind Is Nothing Then
rgFind.Offset(0, 4).Value = tmpVal(0, i - 1)
'--- mettre en forme
Mef (rgFind.Offset(0, 4))
'--- fin forme
rgFind.Offset(0, 5).Value = tmpVal(2, i - 1)
Else
derlg = [A65000].End(xlUp).Row
With Range("A" & derlg + 1)
.Value = tmpVal(1, i - 1) '--------------- N
.Offset(0, 1).Value = tmpVal(2, i - 1) '-- Tr
.Offset(0, 2).Value = tmpVal(3, i - 1) '-- Pr
.Offset(0, 3).Value = tmpVal(4, i - 1) '-- L3
.Offset(0, 4).Value = tmpVal(0, i - 1) '-- AD
Mef (.Offset(0, 4))
.Offset(0, 5).Value = tmpVal(5, i - 1) '-- Pt
End With
End If
Next i
End Sub |
Partager