ElseIf tTab(lined, 10) = "L" And tTab(lined, 3) = tTab(lined - 1, 3) And tTab(lined - 1, 15) > 6800 Then
tTab(lined, 3) = tTab(lined - 1, 3)
Sub Dispatcher()
Dim i As Long ' Compteur : Nombre de lignes du tableau (les lignes excel sont de type Long)
Dim sh As Worksheet
' Placer les données de l'Extrait-SAP dans un tableau
With Sheets("Extrait-SAP")
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
'Si la 3ème ligne après la ligne en cours = "L" en colonne 10 j=4 sinon 2
j = Array(2, 4)(Abs(.Cells(i + 2, 12) = "L"))
'Si la Qi >6800 alors la feuille sera la feuille Sup sinon Inf
If .Cells(i, 17) > 6800 Then Set sh = Sheets("Sup") Else Set sh = Sheets("Inf")
'Transfert des données adapter suivant besoin
sh.Cells(Rows.Count, 1).End(xlUp)(2).Resize(j, 19).Value = .Cells(i, 1).Resize(j, 19).Value
i = i + j - 1
Next
End With
End Sub
' Transfert des données adapter suivant besoin
sh.Cells(Rows.Count, 1).End(xlUp)(2).Resize(j, 19).Value = .Cells(i, 1).Resize(j, 19).Value
pour le coup c'est moi qui ne comprend pas.Car J n'a pour valeur que 2 ou 4 pour former le bloc GD ou GDLR.
Sub Dispatcher()
Dim i As Long ' Compteur : Nombre de lignes du tableau (les lignes excel sont de type Long)
Dim shDestination As Worksheet
Dim Source As Range
' Placer les données de l'Extrait-SAP dans un tableau
With Sheets("Extrait-SAP")
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
'Si la 3ème ligne après la ligne en cours = "L" en colonne 10 j=4 sinon 2
j = Array(2, 4)(Abs(.Cells(i + 2, 12) = "L"))
'Si la Qi >68000 alors la feuille sera la feuille Sup sinon Inf
If .Cells(i, 17) > 6800 Then Set shDestination = Sheets("Sup") Else Set shDestination = Sheets("Inf")
Set Source = .Cells(i, 1).Resize(j, 19)
Répartir Source, shDestination
i = i + j - 1
Next
End With
End Sub
Private Sub Répartir(rngSource As Range, shDestination As Worksheet)
Dim numLigne As Long
Dim r As Range
For Each r In rngSource.Rows 'Parcours des lignes source
With shDestination
numLigne = shDestination.Cells(Rows.Count, 1).End(xlUp)(2).Row
.Cells(numLigne, 1) = r.Cells(1, 5)
.Cells(numLigne, 2) = r.Cells(1, 15)
.Cells(numLigne, 3) = r.Cells(1, 17)
.Cells(numLigne, 4) = r.Cells(1, 8)
End With
Next
End Sub
Private Sub Dispatcher()
Dim i As Long ' Compteur : Nombre de lignes du tableau (les lignes excel sont de type Long)
Dim shDestination As Worksheet
Dim Source As Range
Dim Source2 As Range
' Placer les données de l'Extrait-SAP dans un tableau
With Sheets("Extrait-SAP")
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
'Si la 3ème ligne après la ligne en cours = "L" en colonne 10 j=4 sinon 2
j = Array(2, 4)(Abs(.Cells(i + 2, 12) = "L"))
' Si la Qi >6800 alors la feuille sera la feuille Sup sinon Inf
If .Cells(i, 17) > 6800 Then
Set shDestination = Sheets("Sup")
Else
Set shDestination = Sheets("Inf")
End If
Set Source = .Cells(i, 1).Resize(j, 18)
Répartir Source, shDestination
' Renforts
If .Cells(i, 12) = "L" Then
k = Array(0, 2)(Abs(.Cells(i + 1, 12) = "R"))
End If
Set Source2 = .Cells(i, 1).Resize(j, 18)
Répartir Source2, Sheets("Renf")
i = i + j - 1
Next i
End With
End Sub
Sub ExtraireLR()
Dim shDestination As Worksheet
Set shDestination = GetWorkSheet(SheetName:="LR")
With shDestination
.Rows.Delete
.Range("A1:A3") = Application.Transpose(Array("Page", "L", "R"))
Sheets("Extrait-SAP").Range("A1:R27").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=.Range("A1:A3"), _
CopyToRange:=.Range("A5"), _
Unique:=False
'supprimer la plage de critères
.Rows("1:4").EntireRow.Delete
End With
End Sub
Function GetWorkSheet(SheetName As String, Optional Wkb As Workbook = Nothing, Optional CreateIfNotExists As Boolean = True) As Worksheet
'-----------------------------------------------------------------------------------------------------------
' Author : hasco 10/05/2002
' Objet : Renvoyer une feuille en la créant si nécessaire
' SheetName : Obligatoire, Nom de la feuille à chercher et/ou créer
' Wkb : Facultatif, Classeur dans lequel effectuer la recherche et/ou création
' si non renseigné, le classeur sera le classeur Actif
'CreateIfNotExists : optionel booleen indique s'il faut créer ou non la feuille (oui par défaut)
'-----------------------------------------------------------------------------------------------------------
'
If Wkb Is Nothing Then Set Wkb = ActiveWorkbook
On Error Resume Next
Set GetWorkSheet = Wkb.Sheets(SheetName)
If GetWorkSheet Is Nothing And CreateIfNotExists Then
Set GetWorkSheet = Wkb.Sheets.Add
GetWorkSheet.Name = SheetName
End If
End Function