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 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
| Option Compare Text
Sub ImportDonnees()
Application.ScreenUpdating = False
Dim i As Integer, j As Integer
F1 = "fichier d'arrivée.xlsm"
F2 = "informations de départ.xlsx"
'******************************************************************************************
'Relevé des données
Windows(F2).Activate
NbFeuilDep = Sheets.Count
ReDim FeuilDep(100) As String
ReDim NbLig(10000) As Long
ReDim N°Comm(NbFeuilDep, 100000) As String
ReDim NomComm(NbFeuilDep, 100000) As String
ReDim Montant(NbFeuilDep, 100000) As Double
For i = 1 To NbFeuilDep
FeuilDep(i) = Sheets(i).Name
If Left(FeuilDep(i), 4) <> "INFO" Then
NbLig(i) = Sheets(FeuilDep(i)).[A100000].End(xlUp).Row
For j = 1 To NbLig(i)
N°Comm(i, j) = Sheets(FeuilDep(i)).Cells(j, 3)
NomComm(i, j) = Sheets(FeuilDep(i)).Cells(j, 4)
Montant(i, j) = Sheets(FeuilDep(i)).Cells(j, 7)
Next j
Else
N°Comm(i, j) = ""
End If
Next i
'******************************************************************************************
'Restitution des données
Windows(F1).Activate
For i = 1 To NbFeuilDep
Debut:
On Error Resume Next
If Left(FeuilDep(i), 4) = "INFO" Then GoTo Suivant
For j = 1 To NbLig(i)
If N°Comm(i, j) = "" Then GoTo Suivant
Set d = Sheets(FeuilDep(i)).Columns("A").Find(N°Comm(i, j), LookIn:=xlValues)
If Err.Number = 0 Then
If Not d Is Nothing Then
Dec = 1
Do While d.Offset(0, Dec + 1) <> ""
Dec = Dec + 1
Loop
d.Offset(0, Dec + 1) = Abs(Montant(i, j))
Else
Cells([A100000].End(xlUp).Row + 1, 1) = N°Comm(i, j)
Cells([A100000].End(xlUp).Row, 2) = NomComm(i, j)
Cells([A100000].End(xlUp).Row, 4) = Abs(Montant(i, j))
End If
Else
GoTo CreerFeuille
End If
Next j
'Tri sur colonne A
DerLig = [A8].End(xlDown).Row
Range("A8:N" & DerLig).Select
ActiveWorkbook.Worksheets(FeuilDep(i)).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(FeuilDep(i)).Sort.SortFields.Add Key:=Range("A8:A" & DerLig), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(FeuilDep(i)).Sort
.SetRange Range("A8:N" & DerLig)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Suivant:
Next i
Exit Sub
'******************************************************************************************
CreerFeuille:
Sheets.Add
ActiveSheet.Name = FeuilDep(i)
[A1] = "Mettre : ""Section""+ nom de l'onglet"
Range("C6:N6").Value = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
Range("A7:B7").Value = Array("N°COMMERCIAL", "NOM COMMERCIAL")
On Error GoTo 0
GoTo Debut
End Sub |
Partager