Macro VBA - Transformer tableau 1 en tableau 2
Bonjour,
Je reviens vers vous car j'ai réussi à faire fonctionner le code dans mon fichier de test. Cependant, lorsque je l'exécute dans mon fichier d'export qui sera à chaque fois la vrai base cela ne fonctionne pas voici mon code :
Option Explicit
Sub recap()
Dim i As Long, lig As Long, col As Byte, nbjour As Byte, ctrl As Boolean
Dim t As Long, n As Long
Dim ws As Worksheet
Dim lo As ListObject
Dim LastRow As Long
Dim LastCol As Long
Dim DataRange As Range
On Error Resume Next
Sheets(1).Name = "Détail"
' Définir la feuille de travail active
' Définir la feuille de travail active
Set ws = ActiveSheet
' Trouver la dernière ligne avec des données
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Trouver la dernière colonne avec des données
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' Vérifier si le nombre d'objets de liste sur la feuille est de 0
If ws.ListObjects.Count = 0 Then
' Définir la plage de données en fonction de la dernière ligne et la dernière colonne
Set DataRange = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, LastCol))
' Ajouter un nouvel objet de liste avec la plage dynamique
Set lo = ws.ListObjects.Add(xlSrcRange, DataRange, , xlYes)
lo.Name = "détail"
End If
If FeuilleExiste("Nb jours") = False Then
Sheets("Détail").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Nb jours"
Sheets("Nb jours").ListObjects(1).Name = "nbjours"
[nbjours].Columns(10).Delete
[nbjours].Columns(9).Delete
Sheets("Nb jours").Shapes.Range(Array("Button 1")).Delete
End If
If FeuilleExiste("Nb cas") = False Then
Sheets("Détail").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Nb cas"
Sheets("Nb cas").ListObjects(1).Name = "nbcas"
Range("nbcas[[#Headers],[Nb jour]]").FormulaR1C1 = "Nb Cas"
[nbcas].Columns(10).Delete
[nbcas].Columns(9).Delete
Range("nbcas[[#Headers],[Date début]]").FormulaR1C1 = "Date début rapport"
Range("nbcas[[#Headers],[Date fin]]").FormulaR1C1 = "Date fin rapport"
Sheets("Nb cas").Shapes.Range(Array("Button 1")).Delete
End If
If [nbjours].Item(1, 1) <> "" Then [nbjours].Delete 'on efface nbjours
If [nbcas].Item(1, 1) <> "" Then [nbcas].Delete 'on efface nbcas
ctrl = True
Dim totalG As Double ' Variable pour stocker la somme accumulée de la colonne G
For i = 1 To [détail].Rows.Count
If [détail].Item(i, 8) = "" Then
ctrl = True
Else
If ctrl = True Or [nbjours].Item(lig, 3) <> [détail].Item(i, 3) Then
If [nbjours].Item(1, 1) <> "" Then lig = [nbjours].Rows.Count + 1 Else lig = 1 'RECAP premiere ligne vide
For col = 1 To 8: [nbjours].Item(lig, col) = [détail].Item(i, col): Next
nbjour = 1
totalG = [détail].Item(i, 7) / [détail].Item(i, 4) ' Calcul de la division
[nbjours].Item(lig, 7) = totalG ' Stockage de la somme accumulée dans la colonne G (index 7) du deuxième tableau
ctrl = False: n = 0
For t = 1 To [nbcas].Rows.Count
If [nbcas].Item(t, 3) = [détail].Item(i, 3) And [nbcas].Item(t, 8) = [détail].Item(i, 8) Then
n = t
Exit For
End If
Next
If n = 0 Then
If [nbcas].Item(1, 1) <> "" Then n = [nbcas].Rows.Count + 1 Else n = 1 'type premiere ligne vide
End If
For col = 1 To 4: [nbcas].Item(n, col) = [détail].Item(i, col): Next
If [nbcas].Item(n, 5) = "" Then [nbcas].Item(n, 5) = [détail].Item(i, 9)
[nbcas].Item(n, 6) = [détail].Item(i, 10)
[nbcas].Item(n, 7) = [nbcas].Item(n, 7) + 1
[nbcas].Item(n, 8) = [détail].Item(i, 8)
Else
nbjour = nbjour + 1
totalG = totalG + ([détail].Item(i, 7) / [détail].Item(i, 4)) ' Accumulation de la somme
[nbjours].Item(lig, 7) = totalG ' Stockage de la somme accumulée dans la colonne G (index 7) du deuxième tableau
[nbjours].Item(lig, 6) = [détail].Item(i, 6)
'nbjour = nbjour + 1'
'[nbjours].Item(lig, 7) = nbjour'
'[nbjours].Item(lig, 6) = [détail].Item(i, 6)'
'[nbcas].Item(n, 6) = [détail].Item(i, 10)'
End If
End If
Next
MsgBox ("Transfert terminé")
End Sub
Public Function FeuilleExiste(FeuilleAVerifier As String) As Boolean 'fonction qui vérifie si la "FeuilleAVerifier" existe dans le Classeur actif
On Error GoTo SiErreur
Dim Feuille
FeuilleExiste = False
For Each Feuille In Sheets
If UCase(Feuille.Name) = UCase(FeuilleAVerifier) Then
FeuilleExiste = True
Exit Function
End If
Next Feuille
Exit Function
SiErreur:
FeuilleExiste = CVErr(xlErrNA)
End FunctionMon export a exactement le même nombre de colonne mais à la seule différence de mes fichiers tests que vous pourrez voir dans l'historique des échanges. C'est que lorsque la valeur en colonne 3 donc (nom-prénom) passe à une autre personne, les colonnes Date début et Date fin reviennent au début ce sont pas une continuité de date comme dans les fichiers que j'ai partagé dernièrement. La colonne 9 et 10 ne changent chez personne ils sont définie lors de l'export c'est donc un export de tel à tel date et donc les dates de suivies se trouve durant cette période donc si les périodes définies sont du 01.01.2023 au 30.06.2023 en colonne 9 et 10 on va avoir des lignes exemple (colonne 5 et 6):
01.01.2023 01.01.2023
02.01.2023 02.01.2023
etc... jusqu'à la ligne
30.06.2023 30.06.2023
Ensuite dans l'ordre la valeur (nom-prénom) en colonne 3 change et ça recommence pareil.
Donc je voudrais réussir à faire fonctionner le code ici présent qui fonctionne sur un fichier (voir un des fichiers des échanges antérieurs) mais pour ce cas là car pour le moment ça ne fonctionne pas et j'ai essayé d'ajouté à cette partie du code
For i = 1 To [détail].Rows.Count
If [détail].Item(i, 8) = "" Then
ctrl = True
Elsela condition suivante
For i = 1 To [détail].Rows.Count
If [détail].Item(i, 8) = "" Or [détail].Item(i, 1) = "" Or [détail].Item(i, 4) = "" Or [détail].Item(i, 7) = "" Then
ctrl = True
Elsemais rien n'y fait pour que le système fasse correctement la sortie que j'attends la feuile Nb jours et Nb cas mais sur cette export.
En vous remerciant d'avance pour votre aide . :)