XL 2016 VBA : trouver doublons, triplons, quadruplons, etc...

Phillip · 19 Novembre 2020

Bonjour,

je ne trouve pas sur le net ce qui peut correspondre à mon besoin.

J'ai une série de variables (Une vingtaine) calculée dans une macro, et je voudrais savoir s'il y en a une (ou plusieurs!) qui apparait 5 fois (et laquelle !), 4 fois et lesquelles, 3 fois, 2 fois....

la formule Nb.si compte bien les occurences dans une plage, mais il faut déjà savoir ce que l'on cherche, et je veux de toutes façons l'intégrer dans ma macro.

J'ai tenté un array comme dans le code suivant, mais il ne trouve pas la deuxième occurence, et comment faire pour plus de 20 ou 30 variables ?

VB:

Sub nbsi()

VarA = A
VarB = B
VarC = C
VarD = D
VarE = A


Mon_Tableau = Array(0,VarA, VarB, VarC, VarD, VarE)
For i = LBound(Mon_Tableau) To UBound(Mon_Tableau)
    If i = A Then
    totalA = totalA + 1
    End If
Next i

End Sub

J'ai fixé VarA, VarB, etc...dans le code exemple pour simplifier, mais dans mon code réel je ne connais pas à l'avance leur valeur, puisque ce sont des....variables !

Des idées ?

Merci

Cordialement

Phillip

laurent950 · 19 Novembre 2020

Bonsoir

VB:

Sub nbsi()
' Variable existante dans le module au fils du code.
VarA = "A"
VarB = "D"
VarC = "A"
VarD = "B"
VarE = "D"

' Pour récupération des variable existantes dans un tableau :
Mon_Tableau = Array([{"VarA","",""}], [{"VarB","",""}], [{"VarC","",""}], [{"VarD","",""}], [{"VarE","",""}])

For i = LBound(Mon_Tableau) To UBound(Mon_Tableau)
    Select Case Mon_Tableau(i)(1)
        Case "VarA"
            Mon_Tableau(i)(2) = VarA
        Case "VarB"
            Mon_Tableau(i)(2) = VarB
        Case "VarC"
            Mon_Tableau(i)(2) = VarC
        Case "VarD"
            Mon_Tableau(i)(2) = VarD
        Case "VarE"
            Mon_Tableau(i)(2) = VarE
    End Select
Next i

' recherche des doublons des variable existante :
Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = TextCompare
Dim cef As String

    For i = LBound(Mon_Tableau) To UBound(Mon_Tableau)
        clef = Mon_Tableau(i)(2)
        If d.Exists(clef) Then
            cpt = d(clef)
                Mon_Tableau(cpt)(3) = Mon_Tableau(cpt)(3) + 1
                        For j = LBound(Mon_Tableau) To UBound(Mon_Tableau)
                            If Mon_Tableau(cpt)(2) = Mon_Tableau(j)(2) Then
                                Mon_Tableau(j)(3) = Mon_Tableau(cpt)(3)
                            End If
                        Next j
        Else
            cpt = d.Count
            d(clef) = cpt
                Mon_Tableau(i)(3) = 1
        End If
    Next i
    
' Etats des Variable en avec ou sans doublons dans la Feuille excel :
For i = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
    For j = LBound(Mon_Tableau(i), 1) To UBound(Mon_Tableau(i), 1)
        Cells(i + 1, j) = Mon_Tableau(i)(j)
    Next j
Next i

End Sub

laurent950 · 20 Novembre 2020

Bonjour,
Avec ce code c'est plus simple :
ajout de nouvelle variable (dans la variable tableau, avec deux fonctions)
exemple la variable Var9 (est ajouter en fin de code pour test)

VB:

Sub nbsi()
' Pour récupération des variable existantes dans un tableau :
Dim Mon_Tableau() As Variant
    ReDim Mon_Tableau(1 To 3, 1 To 8)
' Variable existante dans le module au fils du code.
Var1 = 20: Mon_Tableau(1, 1) = "Var1": Mon_Tableau(2, 1) = Var1
Var2 = 45: Mon_Tableau(1, 2) = "Var2": Mon_Tableau(2, 2) = Var2
Var3 = 45: Mon_Tableau(1, 3) = "Var3": Mon_Tableau(2, 3) = Var3
Var4 = 20: Mon_Tableau(1, 4) = "Var4": Mon_Tableau(2, 4) = Var4
Var5 = 45: Mon_Tableau(1, 5) = "Var5": Mon_Tableau(2, 5) = Var5
Var6 = 78: Mon_Tableau(1, 6) = "Var6": Mon_Tableau(2, 6) = Var6
Var7 = 89: Mon_Tableau(1, 7) = "Var7": Mon_Tableau(2, 7) = Var7
Var8 = 89: Mon_Tableau(1, 8) = "Var8": Mon_Tableau(2, 8) = Var8

' Recherche des doublon
DoublonTriplonEtc Mon_Tableau
   
' Copie vers excel
CopieXls Mon_Tableau

' **********************************************************************************************

' TEST AJOUT D'UNE NOUVELLE VALEUR DE VARIABLE AU FILS DU CODE
Var9 = 45: Mon_Tableau(1, 9) = "Var9": Mon_Tableau(2, 9) = Var9

' Recherche des doublon
DoublonTriplonEtc Mon_Tableau
   
' Copie vers excel
CopieXls Mon_Tableau


End Sub

Sub DoublonTriplonEtc(ByRef Mon_Tableau() As Variant)
' recherche des doublons des variable existante :
Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = TextCompare
Dim cef As String

' transpose
Mon_Tableau = Application.Transpose(Mon_Tableau)

    For i = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
        clef = Mon_Tableau(i, 2)
        If d.Exists(clef) Then
            cpt = d(clef)
                Mon_Tableau(cpt, 3) = Mon_Tableau(cpt, 3) + 1
                        For j = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
                            If Mon_Tableau(cpt, 2) = Mon_Tableau(j, 2) Then
                                Mon_Tableau(j, 3) = Mon_Tableau(cpt, 3)
                            End If
                        Next j
        Else
            cpt = i 'd.Count + 1
            d(clef) = cpt
                Mon_Tableau(i, 3) = 1
        End If
    Next i
End Sub

Sub CopieXls(ByRef Mon_Tableau() As Variant)

' Etats des Variable en avec ou sans doublons dans la Feuille excel :
For i = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
    For j = LBound(Mon_Tableau, 2) To UBound(Mon_Tableau, 2)
        Cells(i, j) = Mon_Tableau(i, j)
    Next j
Next i
' transpose
    Mon_Tableau = Application.Transpose(Mon_Tableau)
        ReDim Preserve Mon_Tableau(1 To 3, 1 To UBound(Mon_Tableau, 2) + 1)
End Sub

Phillip · 24 Novembre 2020

Bonjour Laurent950 et tous,

pardon, je n'avais pas vu les derniers posts !

Le code du post17 me semble répondre à mon besoin ! Il faut que je le teste et adapte à ma macro ! En tous, c'est impressionant, merci !

Cordialement

Phillip

Phillip · 25 Novembre 2020

Bonjour Laurent950,

J'ai modifié le code pour que le tableau se replisse en fonction de valeurs variables.

VB:

' Pour récupération des variables existantes dans un tableau :
Dim Mon_Tableau() As Variant
    ReDim Mon_Tableau(1 To 3, 1 To 8)
' variable existante dans le module au fils du code.
poste1:  Mon_Tableau(1, 1) = "poste1": Mon_Tableau(2, 1) = poste1
poste2:  Mon_Tableau(1, 2) = "poste2": Mon_Tableau(2, 2) = poste2
poste3:  Mon_Tableau(1, 3) = "poste3": Mon_Tableau(2, 3) = poste3
poste4:  Mon_Tableau(1, 4) = "poste4": Mon_Tableau(2, 4) = poste4
poste5:  Mon_Tableau(1, 5) = "poste5": Mon_Tableau(2, 5) = poste5
poste6:  Mon_Tableau(1, 6) = "poste6": Mon_Tableau(2, 6) = poste6
poste7:  Mon_Tableau(1, 7) = "poste7": Mon_Tableau(2, 7) = poste7
poste8:  Mon_Tableau(1, 8) = "poste8": Mon_Tableau(2, 8) = poste8

Ce qui fonctionne très bien...

En revanche, ça ne m'intéresse pas trop de récupérer un tableau sur une feuille excel de ce style

Pourrais-je te demander encore du temps de neurones disponibles pour modifier le code pour avoir, soit dans l’idéal dans une variable au coeur de la macro, soit au pire dans une cellule d'une feuille quelque chose comme ça ?

Merci encore

Cordialement

laurent950 · 25 Novembre 2020

Bonjour,

VB:

Sub nbsi()
' Pour récupération des variable existantes dans un tableau :
Dim Mon_Tableau() As Variant
    ReDim Mon_Tableau(1 To 3, 1 To 8)
' Variable existante dans le module au fils du code.
Mon_Tableau(1, 1) = "Var1": Mon_Tableau(2, 1) = Var1 ' Var1 = 20: 
Mon_Tableau(1, 2) = "Var2": Mon_Tableau(2, 2) = Var2 ' Var2 = 45: 
Mon_Tableau(1, 3) = "Var3": Mon_Tableau(2, 3) = Var3 ' Var3 = 45: 
Mon_Tableau(1, 4) = "Var4": Mon_Tableau(2, 4) = Var4 ' Var4 = 20: 
Mon_Tableau(1, 5) = "Var5": Mon_Tableau(2, 5) = Var5 ' Var5 = 45: 
Mon_Tableau(1, 6) = "Var6": Mon_Tableau(2, 6) = Var6 ' Var6 = 78: 
Mon_Tableau(1, 7) = "Var7": Mon_Tableau(2, 7) = Var7 ' Var7 = 89: 
Mon_Tableau(1, 8) = "Var8": Mon_Tableau(2, 8) = Var8 ' Var8 = 89: 

' Recherche des doublon
DoublonTriplonEtc Mon_Tableau
  
' Copie vers excel
CopieXls Mon_Tableau

' **********************************************************************************************

' TEST AJOUT D'UNE NOUVELLE VALEUR DE VARIABLE AU FILS DU CODE
Mon_Tableau(1, 9) = "Var9": Mon_Tableau(2, 9) = Var9 ' Var9 = 45: 

' Recherche des doublon
DoublonTriplonEtc Mon_Tableau
  
' Copie vers excel
CopieXls Mon_Tableau


End Sub

Sub DoublonTriplonEtc(ByRef Mon_Tableau() As Variant)
' recherche des doublons des variable existante :
Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = TextCompare
Dim cef As String

' transpose
Mon_Tableau = Application.Transpose(Mon_Tableau)

    For i = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
        clef = Mon_Tableau(i, 2)
        If d.Exists(clef) Then
            cpt = d(clef)
            If Mon_Tableau(i, 1) <> "" Then
                Mon_Tableau(cpt, 1) = Mon_Tableau(cpt, 1) & "-" & Mon_Tableau(i, 1)
            End If
                Mon_Tableau(cpt, 3) = Mon_Tableau(cpt, 3) + 1
                Mon_Tableau(i, 1) = ""
                        For j = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
                            If Mon_Tableau(cpt, 2) = Mon_Tableau(j, 2) Then
                                If Mon_Tableau(i, 1) <> "" Then
                                    Mon_Tableau(j, 3) = Mon_Tableau(cpt, 3)
                                End If
                            End If
                        Next j
        Else
            cpt = i 'd.Count + 1
            d(clef) = cpt
                Mon_Tableau(i, 3) = 1
        End If
    Next i
End Sub

Sub CopieXls(ByRef Mon_Tableau() As Variant)
Dim Lig As Integer: Lig = 1
' Etats des Variable en avec ou sans doublons dans la Feuille excel :
For i = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
    For j = LBound(Mon_Tableau, 2) To UBound(Mon_Tableau, 2)
        If Mon_Tableau(i, 1) <> "" Then
            Cells(Lig, j) = Mon_Tableau(i, j)
            If j = 3 Then Lig = Lig + 1
        End If
    Next j
Next i
' transpose
    Mon_Tableau = Application.Transpose(Mon_Tableau)
        ReDim Preserve Mon_Tableau(1 To 3, 1 To UBound(Mon_Tableau, 2) + 1)
End Sub

Phillip · 25 Novembre 2020

Pardon, je ne vois pas où est la différence ?

Bon, je ne m'en sors pas...Je vais être obligé de solliciter une modification encore, mais je vérifie encore pour être sûr de ce que je veux cette fois-ci....:-(

laurent950 · 25 Novembre 2020

Re,
Poster tous votre code. c'est plus simple pour corriger

Phillip · 25 Novembre 2020

Je veux bien donner le code et le fichier avec ce que je souhaite où je le souhaite ?

laurent950 · 25 Novembre 2020

Re,
Poster votre code sans le fichier je regarde

Phillip · 25 Novembre 2020

Bonjour,

Voici le code. Tout est basé sur les données nom, prénom, date de naissance entrées en
prenom = LCase(Cells(2, 2).Value)
nom = LCase(Cells(2, 3).Value)
DateNaissance = Cells(2, 4).Value

sur la feuille "Calculs"...Ne vous inquiétez pas de EE...

La macro calcule tout un tas de postes basés sur les entrées de la feuille. Ces résultats vont de 1 à 22. J'ai annoté le code en chapitres. Cela me sort de valeurs pour les variables des chapitres 1 et 2, et pour le chapitre 3 je mets un résultat en dur en fonction de la présence d'une combinaison dans les valeurs des chapitres 1 et 2.

Je veux, que dans un endroit de ma feuille je puisse identifier quelles valeurs des chapitres 1,2,3 sont en double, triple, peut-être quadruple, très rarissimement quintuple...

Le chapitre 3 est particuliers car les combinaisons sont codées en dur...Il faudrait que je puisse les "reséparer pour compter les doublons..

Par exemple, une ligne
If Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 1 Then
Cells(49, 2).Value = "Bateleur + Maison Dieu"
Il faudrait que j'identifie le 1 et le 16 et que je vérifie si je n'ai pas déjà 1 ou 16 dans les chapitres 1, 2 et ailleurs dans le 3...

J'espère avoir été clair...C.'est compliqué d'expliquer et de reprendre le code de quelqu'un j'en suis conscient...

VB:

Sub Theme_Astral()

'protection à garder, donc enlever ces 2 lignes
Sheets("Calculs").Unprotect
Sheets("EE").Unprotect
Application.ScreenUpdating = False

'Dim poste1 As Byte
'Dim journ As Byte
'Dim anneen As Integer
'Dim moisn As Byte
'Dim nom As String
'Dim prenom As String
'Dim anneeNR As Integer

'chemin à modifier
Const fp$ = "C:\Users\JTMQ6376\Desktop\testetoile\arcane"
  Dim po, pg, ph 'poste, position gauche, position haut
  Dim Img As Picture, k As Byte, i As Byte
'Dim poste1 As Byte
'Dim poste2 As Byte
'Dim poste3 As Byte
'Dim poste4 As Byte
'Dim poste5 As Byte
'Dim poste6 As Byte
'Dim poste7 As Byte
'Dim poste8 As Byte
'Dim poste9 As Byte
'Dim poste10 As Byte
'Dim poste11 As Byte
'Dim poste12 As Byte
'Dim poste14 As Byte
'Dim poste15 As Byte
'Dim poste16 As Byte
'Dim poste17 As Byte
Dim Tableau_arcanes As Variant
'Dim i As Integer

'===============================================================================================================
'nettoyage des zones
'===============================================================================================================
'Cells(6, 3).Interior.Color = RGB(255, 0, 0)
Range(Cells(4, 3), Cells(38, 3)).ClearContents
Range(Cells(49, 2), Cells(108, 2)).ClearContents

'===============================================================================================================
'couleur de fond
'================================================================================================================
'Cells.Interior.Color = RGB(164, 0, 121)

'Initialisation des variables et constantes
poste1 = 0
poste2 = 0
poste3 = 0
poste4 = 0
poste5 = 0
poste6 = 0
poste7 = 0
poste8 = 0
poste9 = 0
poste10 = 0
poste11 = 0
poste12 = 0
poste13 = 0
poste14 = 0
poste15 = 0
poste16 = 0
poste17 = 0
limite = 22
prenom = LCase(Cells(2, 2).Value)
nom = LCase(Cells(2, 3).Value)
DateNaissance = Cells(2, 4).Value
journ = Day(DateNaissance)
moisn = Month(DateNaissance)
anneen = Year(DateNaissance)


jourNR = Left(journ, 1) * 1 + Right(journ, 1) * 1
If jourNR <= limite Then
jourR = jourNR
Else
jourR = Left(jourNR, 1) * 1 + Right(jourNR, 1) * 1
End If

anneeNR = Left(anneen, 1) * 1 + Mid(anneen, 2, 1) * 1 + Mid(anneen, 3, 1) * 1 + Right(anneen, 1) * 1
'MsgBox Left(anneen, 1)
'MsgBox Mid(anneen, 2, 1)
'MsgBox Mid(anneen, 3, 1)
'MsgBox Right(anneen, 1)
If anneeNR <= limite Then
anneeR = anneeNR
Else
anneeR = Left(anneeNR, 1) * 1 + Right(anneeNR, 1) * 1
End If

'===========================================================================
'nombre de caracteres du nom et prenom
'============================================================================
nbcarnom = Len(nom)
NBcarPRENOM = Len(prenom)
'============================================================================

'===================================================================================================
'liste des postes
'POSTE1 : jour réduit + mois
'POSTE2 : annee reduite - mois
'POSTE3 : POSTE1+POSTE2+POSTE5
'POSTE 4 : limite - poste 9
'POSTE 5 : annee reduite + mois + jour
'POSTE 6 : poste1+poste5
'POSTE 7
'POSTE 8
'POSTE 9 : poste1+poste2
'POSTE 10 : total lettres nom
'POSTE 11 : limite -poste10
'POSTE 12 : somme des consonnes
'POSTE 13 :somme des voyelles
'POSTE 14 : poste12 + poste 13
'POSTE 15 : total lettres nom
'POSTE 16 : poste 5 + poste 14
'POSTE 17 : poste 10+ poste16
'==============================================================================================================================
'Les3piliers : jour naissance concaténé avec mois et annéee reduite
'======================================================================================================
'archives intérieures : poste2 + poste 4
'Le don : poste1 + poste9 + poste 12
'l'inclinaison : poste9 + poste11 + poste 13
'reconnaissance du monde : poste6+poste 17
'ma juste place : archivesintérieures+le don+l'inclinaison
'l'accomplissement de l'oeuvre : poste1+poste6
'l'ancrage : poste3+poste10
'arcane cle :   poste7 + poste8
'la tyrolienne d'incarnation : poste3-poste17
'l'envol : poste1+poste4
Sheets("Calculs").Activate

'====================================================================================================

'====================================================================================================
'Chapitre 1 : calcul des postes
'====================================================================================================
'POSTE1 : jour + mois
'====================================================================================================
If journ < limite Then
jourR = journ
Else
jourR = Left(journ, 1) * 1 + Right(journ, 1) * 1
End If
poste1 = jourR + moisn

Cells(5, 3).Value = poste1




'POSTE2 : annee reduite - mois
'===================================================================================================

    poste2 = Abs(anneeR - moisn)
    Debug.Print poste2
    
    If poste2 = 0 Then
    
    ' A VOIR
    Cells(6, 3).Interior.Color = RGB(255, 0, 0)
    MsgBox "Attention ! Cas particulier poste2 qui ne génère pas d'arcane car on a 0"
    Else
    Cells(6, 3).Interior.Color = RGB(164, 0, 121)
    
    End If
Cells(6, 3).Value = poste2



'POSTE 5 : annee reduite + mois + jour
'==================================================================================================
poste5NR = anneeR + moisn + journ
If poste5NR <= 22 Then
    poste5 = Abs(poste5NR)
Else
    poste5 = Abs((Left(poste5NR, 1) * 1 + Right(poste5NR, 1) * 1))
End If
Cells(9, 3).Value = poste5

'POSTE3 : POSTE1+POSTE2+POSTE5
'==================================================================================================
poste3NR = poste5 + poste1 + poste2
If poste3NR <= limite Then
    poste3 = poste3NR
    
Else
poste3 = Abs((Left(poste3NR, 1) * 1 + Right(poste3NR, 1) * 1))
End If

Cells(7, 3).Value = poste3

'POSTE 9 : poste1+poste2
'==================================================================================================
poste9NR = poste1 + poste2
If poste9NR <= limite Then
    poste9 = poste9NR
Else
poste9 = Abs((Left(poste9NR, 1) * 1 + Right(poste9NR, 1) * 1))
End If
Cells(13, 3).Value = poste9
'POSTE 4 : limite - poste 9
'==================================================================================================
poste4 = Abs(limite - poste9)
    If poste4 = 0 Then
    ' A VOIR
    Cells(8, 3).Interior.Color = RGB(255, 0, 0)
    MsgBox "Attention ! Cas particulier poste4 qui ne génère pas d'arcane car on a 0"
    Else
    Cells(8, 3).Interior.Color = RGB(164, 0, 121)
    End If
Cells(8, 3).Value = poste4


'POSTE 6 : poste1+poste5
'==================================================================================================
poste6NR = poste1 + poste5
If poste6NR <= limite Then
    poste6 = poste6NR
Else
poste6 = Abs((Left(poste6NR, 1) * 1 + Right(poste6NR, 1) * 1))
End If
Cells(10, 3).Value = poste6
'
'
'POSTE 7 : a definir
'==========================="=======================================================================
Cells(11, 3).Value = "22"
'POSTE 8 : a definir
'==================================================================================================
Cells(12, 3).Value = "22"
'POSTE 10 : total lettres du nom
'==================================================================================================
PointsCN = Consonnes(nom)
PointsVN = Voyelles(nom)

poste10NR = PointsCN + PointsVN

If poste10NR <= limite Then
    poste10 = poste10NR
'ElseIf Len(Mid(poste10NR, 2, 1)) > 3 Then
'        poste10 = Abs((Left(poste10NR, 1) * 1 + Mid(poste10NR, 2, 1) * 1 + Right(poste10NR, 1) * 1))
Else

poste10 = Abs((Left(poste10NR, 1) * 1 + Right(poste10NR, 1) * 1))
End If
Cells(14, 3).Value = poste10
'POSTE 11 : limite-poste10
'=====================================================================================================
poste11 = Abs(limite - poste10)
    If poste11 = 0 Then
    'cas ou poste 10=22, et donc poste11=0, A VOIR
    Cells(15, 3).Interior.Color = RGB(255, 0, 0)
    MsgBox "Attention ! Cas particulier poste11 qui ne génère pas d'arcane car on a 0"
    Else
    Cells(15, 3).Interior.Color = RGB(164, 0, 121)
    End If

Cells(15, 3).Value = poste11

'POSTE 12 : consonnes nom + prénom, réduit a la fin
'=====================================================================================================
PointsCN = Consonnes(nom)
PointsCP = Consonnes(prenom)

poste12NR = PointsCN + PointsCP
If poste12NR <= limite Then
    poste12 = poste12NR
Else
poste12 = Abs((Left(poste12NR, 1) * 1 + Right(poste12NR, 1) * 1))
End If
Cells(16, 3).Value = poste12

'POSTE 13 : voyelles nom + prénom, réduit a la fin
'======================================================================================================
PointsVN = Voyelles(nom)
PointsVP = Voyelles(prenom)

poste13NonR = PointsVN + PointsVP
If poste13NonR <= limite Then
    poste13 = poste13NonR
Else
poste13 = Abs((Left(poste13NonR, 1) * 1 + Right(poste13NonR, 1) * 1))
End If
Cells(17, 3).Value = poste13

'POSTE 14 : Poste12+poste13
'=======================================================================================================
poste14NR = poste12 + poste13
If poste14NR <= limite Then
    poste14 = poste14NR
Else
poste14 = Abs((Left(poste14NR, 1) * 1 + Right(poste14NR, 1) * 1))
End If
Cells(18, 3).Value = poste14
'POSTE 15 : total lettres prénom
'======================================================================================================
PointsVP = Voyelles(prenom)
PointsCP = Consonnes(prenom)

poste15NR = PointsVP + PointsCP
If poste15NR <= limite Then
    poste15 = poste15NR
Else
poste15 = Abs((Left(poste15NR, 1) * 1 + Right(poste15NR, 1) * 1))
End If
Cells(19, 3).Value = poste15
'POSTE 16 : poste5 et poste14
'=======================================================================================================
poste16NR = poste14 + poste5
If poste16NR <= limite Then
    poste16 = poste16NR
Else
poste16 = Abs((Left(poste16NR, 1) * 1 + Right(poste16NR, 1) * 1))
End If
Cells(20, 3).Value = poste16

'POSTE 17 : somme poste 10 a poste 16
'=======================================================================================================
poste17NR = poste10 + poste11 + poste12 + poste13 + poste14 + poste15 + poste16
If poste17NR <= limite Then
    poste17 = poste17NR
Else
poste17 = Abs((Left(poste17NR, 1) * 1 + Right(poste17NR, 1) * 1))

'juste pour s'arrêter, on supprime apres
'arret = Cells(1, 1).Value
End If
Cells(21, 3).Value = poste17
'Les3piliers
'======================================================================================================




'rajout d'un 0 au jour s'il n'a qu'un chiffre
    If Len(jourR) < 2 Then
    jourR = "0" & jourR
    End If
        'rajout d'un 0 au mois s'il n'a qu'un chiffre
        If Len(moisn) < 2 Then
        moisn = "0" & moisn
        End If
            'rajout d'un 0 a l'annee si elle n'a qu'un chiffre
            If Len(anneeR) < 2 Then
            anneeR = "0" & anneeR
            End If
            
    'Les3Piliers = "0" & jourR & " & " & "0" & moisn & " & " & "0" & anneeR
    
    
    Les3Piliers = jourR & " & " & moisn & " & " & anneeR
        
Cells(4, 3).Value = Les3Piliers
'

'======================================================================================================
'Chapitre 2  : calcul de l'IKIGAI
''======================================================================================================
'archives intérieures : poste2 + poste 4

archintNR = poste2 + poste4

If archintNR <= limite Then
    archint = archintNR
    
Else

archint = Abs((Left(archintNR, 1) * 1 + Right(archintNR, 1) * 1))
End If
Cells(26, 3).Value = archint

'=======================================================================================================
'Le don : poste1 + poste9 + poste 12
LeDonNR = poste1 + poste9 + poste12
If LeDonNR <= limite Then
    LeDon = LeDonNR
Else
LeDon = Abs((Left(LeDonNR, 1) * 1 + Right(LeDonNR, 1) * 1))
End If
Cells(27, 3).Value = LeDon

'=======================================================================================================
'l'inclinaison : poste9 + poste11 + poste 13
LinclinaisonNR = poste9 + poste11 + poste13
If LinclinaisonNR <= limite Then
    Linclinaison = LinclinaisonNR
Else
Linclinaison = Abs((Left(LinclinaisonNR, 1) * 1 + Right(LinclinaisonNR, 1) * 1))
End If
Cells(28, 3).Value = Linclinaison

'=======================================================================================================
'reconnaissance du monde : poste6+poste 17
RecMondeNR = poste6 + poste17
If RecMondeNR <= limite Then
    RecMonde = RecMondeNR
Else
RecMonde = Abs((Left(RecMondeNR, 1) * 1 + Right(RecMondeNR, 1) * 1))
End If
Cells(29, 3).Value = RecMonde

'=======================================================================================================
'ma juste place : archivesintérieures+le don+l'inclinaison+reconnaissance du monde
MaJustePlaceNR = archint + LeDon + Linclinaison + RecMonde
If MaJustePlaceNR <= limite Then
    MaJustePlace = MaJustePlaceNR
Else
MaJustePlace = Abs((Left(MaJustePlaceNR, 1) * 1 + Right(MaJustePlaceNR, 1) * 1))
End If
Cells(30, 3).Value = MaJustePlace

'=======================================================================================================
'l'accomplissement de l'oeuvre : poste1+poste6
AccompoeuvreNR = poste1 + poste6
If AccompoeuvreNR <= limite Then
    Accompoeuvre = AccompoeuvreNR
Else
Accompoeuvre = Abs((Left(AccompoeuvreNR, 1) * 1 + Right(AccompoeuvreNR, 1) * 1))
End If
Cells(33, 3).Value = Accompoeuvre

'=======================================================================================================
'l'ancrage : poste3+poste10

LancrageNR = poste3 + poste10
If LancrageNR <= limite Then
    Lancrage = LancrageNR
    
Else
Lancrage = Abs((Left(LancrageNR, 1) * 1 + Right(LancrageNR, 1) * 1))
End If
Cells(34, 3).Value = Lancrage

'=======================================================================================================
'arcane cle :   poste7 + poste8
ArcaneCleNR = poste7 + poste8
If ArcaneCleNR <= limite Then
    ArcaneCle = ArcaneCleNR
Else
ArcaneCle = Abs((Left(ArcaneCleNR, 1) * 1 + Right(ArcaneCleNR, 1) * 1))
End If
Cells(35, 3).Value = ArcaneCle

'=======================================================================================================
'la tyrolienne d'incarnation : poste3-poste17
'bizarre, ça fait 0 !!!

TyrolincarnNR = poste3 - poste17
If TyrolincarnNR <= limite Then
    Tyrolincarn = Abs(TyrolincarnNR)
Else
Tyrolincarn = Abs((Left(TyrolincarnNR, 1) * 1 + Right(TyrolincarnNR, 1) * 1))
End If
Cells(36, 3).Value = Tyrolincarn

'=======================================================================================================
'l'envol : poste1+poste4
EnvolNR = poste1 + poste4

If EnvolNR <= limite Then
    Envol = Abs(EnvolNR)
    
Else
Envol = Abs((Left(EnvolNR, 1) * 1 + Right(EnvolNR, 1) * 1))
End If
Cells(38, 3).Value = Envol


'=======================================================================================================
'Chapitre 3: les Champs Magnetiques
'=======================================================================================================
'meteor1 : Bateleur et Maison Dieu (1 et 16)
'meteor2 : papesse et diable Dieu (2 et 15)
'meteor3 : papesse et diable Dieu (3 et 14)
'meteor4 : Bateleur et Maison Dieu (4 et 13)
'meteor5 : pape et pendu (5 et 12)
'meteor6 : amoureux et force (6 et 11)
'meteor7 : chariot et roue de la fortune (7 et 10)
'meteor8 : justice et ermite (8 et 9)

  
      
    Tableau_arcanes = Array(poste1, poste2, poste3, poste4, poste5, poste6, poste7, poste8, poste9, poste10, poste11, poste12, poste13, poste14, poste15, poste16, poste17, archint, LeDon, Linclinaison, RecMonde, MaJustePlace, Accompoeuvre, Tyrolincarn, Lancrage, ArcaneCle, Envol)
    
For i = LBound(Tableau_arcanes) To UBound(Tableau_arcanes)
    For j = LBound(Tableau_arcanes) To UBound(Tableau_arcanes)
    'METEORES
        If Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 1 Then
        Cells(49, 2).Value = "Bateleur + Maison Dieu"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 15 Or Tableau_arcanes(j) = 15 And Tableau_arcanes(i) = 2 Then
        Cells(50, 2).Value = "Papesse + Diable" 'meteores
        Cells(74, 2).Value = "Diable + Papesse" 'failles
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 14 Or Tableau_arcanes(j) = 14 And Tableau_arcanes(i) = 3 Then
        Cells(51, 2).Value = "Impératrice + Tempérance"
        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 13 Or Tableau_arcanes(j) = 13 And Tableau_arcanes(i) = 4 Then
        Cells(52, 2).Value = "Empereur + Sans Nom"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 5 Then
        Cells(53, 2).Value = "Pape + Le Pendu"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 6 Then
        Cells(54, 2).Value = "Amoureux + Force"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 10 Or Tableau_arcanes(j) = 10 And Tableau_arcanes(i) = 7 Then
        Cells(55, 2).Value = "Chariot + Roue de La Fortune"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 9 Or Tableau_arcanes(j) = 9 And Tableau_arcanes(i) = 8 Then
        Cells(56, 2).Value = "Justice + Ermite"
    'INTEGRITE
        ElseIf Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 1 Then
        Cells(59, 2).Value = "Bateleur + Pendu"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 2 Then
        Cells(60, 2).Value = "Papesse + Force"
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 10 Or Tableau_arcanes(j) = 10 And Tableau_arcanes(i) = 3 Then
        Cells(61, 2).Value = "Impératrice + Roue de Fortune"
        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 9 Or Tableau_arcanes(j) = 9 And Tableau_arcanes(i) = 4 Then
        Cells(62, 2).Value = "Empereur + Ermite"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 8 Or Tableau_arcanes(j) = 8 And Tableau_arcanes(i) = 5 Then
        Cells(63, 2).Value = "Pape + Justice"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 7 Or Tableau_arcanes(j) = 7 And Tableau_arcanes(i) = 6 Then
        Cells(64, 2).Value = "Amoureux + Chariot"
     'LES FAILLES
        ElseIf Tableau_arcanes(i) = 9 And Tableau_arcanes(j) = 22 Or Tableau_arcanes(j) = 22 And Tableau_arcanes(i) = 9 Then
        Cells(67, 2).Value = "Mat + Ermite"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 21 Or Tableau_arcanes(j) = 21 And Tableau_arcanes(i) = 8 Then
        Cells(68, 2).Value = "Monde + Justice"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 20 Or Tableau_arcanes(j) = 20 And Tableau_arcanes(i) = 7 Then
        Cells(69, 2).Value = "Jugement + Chariot"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 19 Or Tableau_arcanes(j) = 19 And Tableau_arcanes(i) = 6 Then
        Cells(70, 2).Value = "Soleil + Amoureux"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 18 Or Tableau_arcanes(j) = 18 And Tableau_arcanes(i) = 5 Then
        Cells(71, 2).Value = "Lune + Pape"
        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 17 Or Tableau_arcanes(j) = 17 And Tableau_arcanes(i) = 4 Then
        Cells(72, 2).Value = "Etoile + Empereur" 'Pour les failles
        Cells(102, 2).Value = "Empereur + Etoile" 'Pour le tour du monde
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 3 Then
        Cells(73, 2).Value = "Impératrice + Maison Dieu" 'les failles
        Cells(79, 2).Value = "Impératrice + Maison Dieu"
'        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 15 Or Tableau_arcanes(j) = 15 And Tableau_arcanes(i) = 2 Then
'        Cells(74, 2).Value = "Diable + Papesse"
    'LE POUVOIR CREATEUR
        ElseIf Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 18 Or Tableau_arcanes(j) = 18 And Tableau_arcanes(i) = 1 Then
        Cells(77, 2).Value = "Bateleur + Lune"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 17 Or Tableau_arcanes(j) = 17 And Tableau_arcanes(i) = 2 Then
        Cells(78, 2).Value = "Papesse + Etoile"
'        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 3 Then
'        Cells(79, 2).Value = "Impératrice + Maison Dieu"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 14 Or Tableau_arcanes(j) = 14 And Tableau_arcanes(i) = 5 Then
        Cells(80, 2).Value = "Pape + Tempérance"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 13 Or Tableau_arcanes(j) = 13 And Tableau_arcanes(i) = 6 Then
        Cells(81, 2).Value = "Amoureux + Sans Nom"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 7 Then
        Cells(82, 2).Value = "Chariot + Pendu"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 8 Then
        Cells(83, 2).Value = "Justice + Force"
        ElseIf Tableau_arcanes(i) = 9 And Tableau_arcanes(j) = 10 Or Tableau_arcanes(j) = 10 And Tableau_arcanes(i) = 9 Then
        Cells(84, 2).Value = "Ermite + Roue de Fortune"
        
    'LA REVELATION
        ElseIf Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 19 Or Tableau_arcanes(j) = 19 And Tableau_arcanes(i) = 1 Then
        Cells(87, 2).Value = "Bateleur + Soleil"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 18 Or Tableau_arcanes(j) = 18 And Tableau_arcanes(i) = 2 Then
        Cells(88, 2).Value = "Papesse + Lune"
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 17 Or Tableau_arcanes(j) = 17 And Tableau_arcanes(i) = 3 Then
        Cells(89, 2).Value = "Impératrice + Etoile"
        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 4 Then
        Cells(90, 2).Value = "Empereur + Maison Dieu"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 15 Or Tableau_arcanes(j) = 15 And Tableau_arcanes(i) = 5 Then
        Cells(91, 2).Value = "Pape + Diable"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 14 Or Tableau_arcanes(j) = 14 And Tableau_arcanes(i) = 6 Then
        Cells(92, 2).Value = "Amoureux + Tempérance"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 13 Or Tableau_arcanes(j) = 13 And Tableau_arcanes(i) = 7 Then
        Cells(93, 2).Value = "Chariot + Sans Nom"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 8 Then
        Cells(94, 2).Value = "Justice + Pendu"
        ElseIf Tableau_arcanes(i) = 9 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 9 Then
        Cells(95, 2).Value = "Force + Ermite"
        ElseIf Tableau_arcanes(i) = 10 Then
        Cells(96, 2).Value = "Roue de Fortune"
        
    'LE TOUR DU MONDE
        ElseIf Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 20 Or Tableau_arcanes(j) = 20 And Tableau_arcanes(i) = 1 Then
        Cells(99, 2).Value = "Bateleur + Jugement"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 19 Or Tableau_arcanes(j) = 19 And Tableau_arcanes(i) = 2 Then
        Cells(100, 2).Value = "Papesse = Soleil"
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 18 Or Tableau_arcanes(j) = 18 And Tableau_arcanes(i) = 3 Then
        Cells(101, 2).Value = "Impératrice + Lune"
'        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 17 Or Tableau_arcanes(j) = 4 And Tableau_arcanes(i) = 17 Then
'        Cells(102, 2).Value = "Empereur + Etoile"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 5 Then
        Cells(103, 2).Value = "Pape + Maison Dieu"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 15 Or Tableau_arcanes(j) = 15 And Tableau_arcanes(i) = 6 Then
        Cells(104, 2).Value = "Amoureux + Diable"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 14 Or Tableau_arcanes(j) = 14 And Tableau_arcanes(i) = 7 Then
        Cells(105, 2).Value = "Chariot + Tempérance"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 13 Or Tableau_arcanes(j) = 13 And Tableau_arcanes(i) = 8 Then
        Cells(106, 2).Value = "Justice + Sans Nom"
        ElseIf Tableau_arcanes(i) = 9 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 9 Then
        Cells(107, 2).Value = "Ermite + Pendu"
        ElseIf Tableau_arcanes(i) = 10 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 10 Then
        Cells(108, 2).Value = "Roue de Fortune + Force"
        End If
    Next j
Next i

'Chapitre 4 : La création de l'étoile évolutive
'==============================================================================================================================
'Insertion des images d'arcanes dans la feuille EE
Sheets("EE").Activate

'Le chemin  = "C:\Users\JTMQ6376\Desktop\testetoile\arcane" sera à changer
'les postes 7 et 8 ne sont pas définis et l'image 22 est mise pour la bonne marche de la macro
poste7 = 22
poste8 = 22
 
  For Each Img In ActiveSheet.Pictures: Img.Delete: Next Img
 
  '22 arcanes ; si non utilisé : mettre 0
 
  '          1           2       3      4       5       6       7    8      9       10          11      12      13      14          15      16      17      18 19 20 21 22
  po = Array(poste1, poste2, poste3, poste4, poste5, poste6, poste7, poste8, poste9, poste10, poste11, poste12, poste13, poste14, poste15, poste16, poste17, 0, 0, 0, 0, 0)
 
  '            1  2    3  4    5    6    7    8    9   10   11   12   13   14   15   16   17 18 19 20 21 22
  pg = Array(167, 2, 385, 0, 665, 842, 838, 665, 166, 467, 467, 467, 467, 467, 467, 467, 385, 0, 0, 0, 0, 0)
 
  '             1    2     3    4     5    6    7    8    9    10    11   12   13   14   15   16 17 18 19 20 21 22
  ph = Array(1269, 988, 1417, 460, 1263, 985, 462, 268, 266, 1138, 1001, 860, 719, 575, 429, 285, 4, 0, 0, 0, 0, 0)
 
  For i = 1 To 22
    k = i - 1 'car pour les 3 arrays po, pg, ph : c'est à partir de 0, pas à partir de 1
    If po(k) > 0 Then ActiveSheet.Shapes.AddPicture Filename:=fp & po(k) & ".jpg", linktofile:=msoFalse, savewithdocument:=msoTrue, _
      Left:=pg(k), Top:=ph(k), Width:=100, Height:=140
  Next i

Sheets("Calculs").Activate
Cells(1, 1).Select


'=======================================================================================================
'arret = Cells(1, 1).Value 'a supprimer apres
Sheets("Calculs").Protect
Sheets("EE").Protect
End Sub
Function Voyelles(injectionV)
Dim PointsV

nbcarnom = Len(injectionV)
Voyelles = 0
For compteur = 1 To nbcarnom
lettreselect = Mid(injectionV, compteur, 1)
Lpoints = 0
Select Case lettreselect
    Case Is = "a"
    Lpoints = 1
    Case Is = "e"
    Lpoints = 5
    Case Is = "i"
    Lpoints = 9
    Case Is = "o"
    Lpoints = 6
    Case Is = "u"
    Lpoints = 3
    Case Is = "y"
    Lpoints = 7
End Select
Voyelles = Voyelles + Lpoints
Next compteur
End Function

Function Consonnes(injectionC)
Dim PointsC

'nom = Cells(2, 3).Value
nbcarnom = Len(injectionC)
Consonnes = 0
For compteur = 1 To nbcarnom
lettreselect = Mid(injectionC, compteur, 1)
Lpoints = 0
Select Case lettreselect
    Case Is = "b"
    Lpoints = 2
    Case Is = "c"
    Lpoints = 3
    Case Is = "d"
    Lpoints = 4
    Case Is = "f"
    Lpoints = 6
    Case Is = "g"
    Lpoints = 7
    Case Is = "h"
    Lpoints = 8
    Case Is = "j"
    Lpoints = 1
    Case Is = "k"
    Lpoints = 2
    Case Is = "l"
    Lpoints = 3
    Case Is = "m"
    Lpoints = 4
    Case Is = "n"
    Lpoints = 5
    Case Is = "p"
    Lpoints = 7
    Case Is = "q"
    Lpoints = 8
    Case Is = "r"
    Lpoints = 9
    Case Is = "s"
    Lpoints = 1
    Case Is = "t"
    Lpoints = 2
    Case Is = "v"
    Lpoints = 4
    Case Is = "w"
    Lpoints = 5
    Case Is = "x"
    Lpoints = 6
    Case Is = "z"
    Lpoints = 8
    
    
End Select
Consonnes = Consonnes + Lpoints
Next compteur
End Function
Function in_array(tableau, recherche)
    
    'https://www.excel-pratique.com/fr/astuces_vba/recherche-tableau-array
    
    in_array = False
    
    For i = LBound(tableau) To UBound(tableau)
        If tableau(i) = recherche Then 'Si valeur trouvée
            in_array = True
            Exit For
        End If
    Next
    
End Function

laurent950 · 25 Novembre 2020

Re,

VB:

Sub Theme_Astral()

' Feuille active
    Dim FActive as worksheet
        Set FActive = worksheets(ActiveSheet.name)

' Ajoute la feuille qui compte les doublons valeurs des chapitres 1,2,3
    FeuilleDoubleTripleQuadruple
dim FDouTriQuad as worksheet
    set FDouTriQuad = Worksheets("FDouTriQuad")

' Feuille active
    FActive.Select

'protection à garder, donc enlever ces 2 lignes
    Sheets("Calculs").Unprotect
    Sheets("EE").Unprotect
    Application.ScreenUpdating = False

'Dim poste1 As Byte
'Dim journ As Byte
'Dim anneen As Integer
'Dim moisn As Byte
'Dim nom As String
'Dim prenom As String
'Dim anneeNR As Integer

'chemin à modifier
    Const fp$ = "C:\Users\JTMQ6376\Desktop\testetoile\arcane"
  Dim po, pg, ph 'poste, position gauche, position haut
  Dim Img As Picture, k As Byte, i As Byte
'Dim poste1 As Byte
'Dim poste2 As Byte
'Dim poste3 As Byte
'Dim poste4 As Byte
'Dim poste5 As Byte
'Dim poste6 As Byte
'Dim poste7 As Byte
'Dim poste8 As Byte
'Dim poste9 As Byte
'Dim poste10 As Byte
'Dim poste11 As Byte
'Dim poste12 As Byte
'Dim poste14 As Byte
'Dim poste15 As Byte
'Dim poste16 As Byte
'Dim poste17 As Byte
Dim Tableau_arcanes As Variant
'Dim i As Integer

'===============================================================================================================
'nettoyage des zones
'===============================================================================================================
'Cells(6, 3).Interior.Color = RGB(255, 0, 0)
    Range(Cells(4, 3), Cells(38, 3)).ClearContents
    Range(Cells(49, 2), Cells(108, 2)).ClearContents

'===============================================================================================================
'couleur de fond
'================================================================================================================
'Cells.Interior.Color = RGB(164, 0, 121)

'Initialisation des variables et constantes
' Pour récupération des variable existantes dans un tableau :
    Dim Mon_Tableau() As Variant
        ReDim Mon_Tableau(1 To 3 1 To 17)
    Mon_Tableau(1, 1) = "poste1": Mon_Tableau(2, 1) = 0 'poste1 = 0
    Mon_Tableau(1, 2) = "poste2": Mon_Tableau(2, 2) = 0 'poste2 = 0
    Mon_Tableau(1, 3) = "poste3": Mon_Tableau(2, 3) = 0 'poste3 = 0
    Mon_Tableau(1, 4) = "poste4": Mon_Tableau(2, 4) = 0 'poste4 = 0
    Mon_Tableau(1, 5) = "poste5": Mon_Tableau(2, 5) = 0 'poste5 = 0
    Mon_Tableau(1, 6) = "poste6": Mon_Tableau(2, 6) = 0 'poste6 = 0
    Mon_Tableau(1, 7) = "poste7": Mon_Tableau(2, 7) = 0 'poste7 = 0
    Mon_Tableau(1, 8) = "poste8": Mon_Tableau(2, 8) = 0 'poste8 = 0
    Mon_Tableau(1, 9) = "poste9": Mon_Tableau(2, 9) = 0 'poste9 = 0
    Mon_Tableau(1, 10) = "poste10": Mon_Tableau(2, 10) = 0 'poste10 = 0
    Mon_Tableau(1, 11) = "poste11": Mon_Tableau(2, 11) = 0 'poste11 = 0
    Mon_Tableau(1, 12) = "poste12": Mon_Tableau(2, 12) = 0 'poste12 = 0
    Mon_Tableau(1, 13) = "poste13": Mon_Tableau(2, 13) = 0 'poste13 = 0
    Mon_Tableau(1, 14) = "poste14": Mon_Tableau(2, 14) = 0 'poste14 = 0
    Mon_Tableau(1, 15) = "poste15": Mon_Tableau(2, 15) = 0 'poste15 = 0
    Mon_Tableau(1, 16) = "poste16": Mon_Tableau(2, 16) = 0 'poste16 = 0
    Mon_Tableau(1, 17) = "poste17": Mon_Tableau(2, 17) = 0 'poste17 = 0
    limite = 22
    prenom = LCase(Cells(2, 2).Value)
    nom = LCase(Cells(2, 3).Value)
    DateNaissance = Cells(2, 4).Value
    journ = Day(DateNaissance)
    moisn = Month(DateNaissance)
    anneen = Year(DateNaissance)


    jourNR = Left(journ, 1) * 1 + Right(journ, 1) * 1
    If jourNR <= limite Then
        jourR = jourNR
    Else
        jourR = Left(jourNR, 1) * 1 + Right(jourNR, 1) * 1
    End If

    anneeNR = Left(anneen, 1) * 1 + Mid(anneen, 2, 1) * 1 + Mid(anneen, 3, 1) * 1 + Right(anneen, 1) * 1
'MsgBox Left(anneen, 1)
'MsgBox Mid(anneen, 2, 1)
'MsgBox Mid(anneen, 3, 1)
'MsgBox Right(anneen, 1)
    If anneeNR <= limite Then
        anneeR = anneeNR
    Else
        anneeR = Left(anneeNR, 1) * 1 + Right(anneeNR, 1) * 1
    End If

'===========================================================================
'nombre de caracteres du nom et prenom
'============================================================================
    nbcarnom = Len(nom)
    NBcarPRENOM = Len(prenom)
'============================================================================

'===================================================================================================
'liste des postes
'POSTE1 : jour réduit + mois
'POSTE2 : annee reduite - mois
'POSTE3 : POSTE1+POSTE2+POSTE5
'POSTE 4 : limite - poste 9
'POSTE 5 : annee reduite + mois + jour
'POSTE 6 : poste1+poste5
'POSTE 7
'POSTE 8
'POSTE 9 : poste1+poste2
'POSTE 10 : total lettres nom
'POSTE 11 : limite -poste10
'POSTE 12 : somme des consonnes
'POSTE 13 :somme des voyelles
'POSTE 14 : poste12 + poste 13
'POSTE 15 : total lettres nom
'POSTE 16 : poste 5 + poste 14
'POSTE 17 : poste 10+ poste16
'==============================================================================================================================
'Les3piliers : jour naissance concaténé avec mois et annéee reduite
'======================================================================================================
'archives intérieures : poste2 + poste 4
'Le don : poste1 + poste9 + poste 12
'l'inclinaison : poste9 + poste11 + poste 13
'reconnaissance du monde : poste6+poste 17
'ma juste place : archivesintérieures+le don+l'inclinaison
'l'accomplissement de l'oeuvre : poste1+poste6
'l'ancrage : poste3+poste10
'arcane cle :   poste7 + poste8
'la tyrolienne d'incarnation : poste3-poste17
'l'envol : poste1+poste4
Sheets("Calculs").Activate

'====================================================================================================

'====================================================================================================
'Chapitre 1 : calcul des postes
'====================================================================================================
'POSTE1 : jour + mois
'====================================================================================================
    If journ < limite Then
        jourR = journ
    Else
        jourR = Left(journ, 1) * 1 + Right(journ, 1) * 1
    End If
        Mon_Tableau(2, 1) = jourR + moisn

        Cells(5, 3).Value = Mon_Tableau(2, 1)


'POSTE2 : annee reduite - mois
'===================================================================================================

    Mon_Tableau(2, 2) = Abs(anneeR - moisn)
    Debug.Print Mon_Tableau(2, 2)

    If Mon_Tableau(2, 2) = 0 Then
    ' A VOIR
        Cells(6, 3).Interior.Color = RGB(255, 0, 0)
        MsgBox "Attention ! Cas particulier poste2 qui ne génère pas d'arcane car on a 0"
    Else
        Cells(6, 3).Interior.Color = RGB(164, 0, 121)
    End If
        Cells(6, 3).Value = Mon_Tableau(2, 2)

'POSTE 5 : annee reduite + mois + jour
'==================================================================================================
    poste5NR = anneeR + moisn + journ
    If poste5NR <= 22 Then
        Mon_Tableau(2, 5) = Abs(poste5NR)
    Else
        Mon_Tableau(2, 5) = Abs((Left(poste5NR, 1) * 1 + Right(poste5NR, 1) * 1))
    End If
        Cells(9, 3).Value = Mon_Tableau(2, 5)

'POSTE3 : POSTE1+POSTE2+POSTE5
'==================================================================================================
    poste3NR = Mon_Tableau(2, 5) + Mon_Tableau(2, 1) + Mon_Tableau(2, 2)
    If poste3NR <= limite Then
        Mon_Tableau(2, 3) = poste3NR
    Else
        Mon_Tableau(2, 3) = Abs((Left(poste3NR, 1) * 1 + Right(poste3NR, 1) * 1))
    End If
    Cells(7, 3).Value = Mon_Tableau(2, 3)

'POSTE 9 : poste1+poste2
'==================================================================================================
    poste9NR = Mon_Tableau(2, 1) + Mon_Tableau(2, 2)
    If poste9NR <= limite Then
        Mon_Tableau(2, 9) = poste9NR
    Else
        Mon_Tableau(2, 9) = Abs((Left(poste9NR, 1) * 1 + Right(poste9NR, 1) * 1))
    End If
        Cells(13, 3).Value = Mon_Tableau(2, 9)

'POSTE 4 : limite - poste 9
'==================================================================================================
Mon_Tableau(2, 4) = Abs(limite - Mon_Tableau(2, 9))
    If Mon_Tableau(2, 4) = 0 Then
    ' A VOIR
        Cells(8, 3).Interior.Color = RGB(255, 0, 0)
        MsgBox "Attention ! Cas particulier poste4 qui ne génère pas d'arcane car on a 0"
    Else
        Cells(8, 3).Interior.Color = RGB(164, 0, 121)
    End If
        Cells(8, 3).Value = Mon_Tableau(2, 4)

'POSTE 6 : poste1+poste5
'==================================================================================================
    poste6NR = Mon_Tableau(2, 1) + Mon_Tableau(2, 5)
    If poste6NR <= limite Then
        Mon_Tableau(2, 6) = poste6NR
    Else
        Mon_Tableau(2, 6) = Abs((Left(poste6NR, 1) * 1 + Right(poste6NR, 1) * 1))
    End If
        Cells(10, 3).Value = Mon_Tableau(2, 6)
'
'
'POSTE 7 : a definir
'==========================="=======================================================================
    Cells(11, 3).Value = "22"
'POSTE 8 : a definir
'==================================================================================================
    Cells(12, 3).Value = "22"
'POSTE 10 : total lettres du nom
'==================================================================================================
    PointsCN = Consonnes(nom)
    PointsVN = Voyelles(nom)

    poste10NR = PointsCN + PointsVN

    If poste10NR <= limite Then
        Mon_Tableau(2, 10) = poste10NR
    'ElseIf Len(Mid(poste10NR, 2, 1)) > 3 Then
    '   Mon_Tableau(2, 10) = Abs((Left(poste10NR, 1) * 1 + Mid(poste10NR, 2, 1) * 1 + Right(poste10NR, 1) * 1))
    Else
        Mon_Tableau(2, 10) = Abs((Left(poste10NR, 1) * 1 + Right(poste10NR, 1) * 1))
    End If
        Cells(14, 3).Value = Mon_Tableau(2, 10)
 
'POSTE 11 : limite-poste10
'=====================================================================================================
Mon_Tableau(2, 11) = Abs(limite - Mon_Tableau(2, 10))
    If Mon_Tableau(2, 11) = 0 Then
    'cas ou poste 10=22, et donc poste11=0, A VOIR
        Cells(15, 3).Interior.Color = RGB(255, 0, 0)
        MsgBox "Attention ! Cas particulier poste11 qui ne génère pas d'arcane car on a 0"
    Else
        Cells(15, 3).Interior.Color = RGB(164, 0, 121)
    End If
        Cells(15, 3).Value = Mon_Tableau(2, 11)

'POSTE 12 : consonnes nom + prénom, réduit a la fin
'=====================================================================================================
    PointsCN = Consonnes(nom)
    PointsCP = Consonnes(prenom)

    poste12NR = PointsCN + PointsCP
    If poste12NR <= limite Then
        Mon_Tableau(2, 12) = poste12NR
    Else
        Mon_Tableau(2, 12) = Abs((Left(poste12NR, 1) * 1 + Right(poste12NR, 1) * 1))
    End If
        Cells(16, 3).Value = Mon_Tableau(2, 12)

'POSTE 13 : voyelles nom + prénom, réduit a la fin
'======================================================================================================
    PointsVN = Voyelles(nom)
    PointsVP = Voyelles(prenom)

    poste13NonR = PointsVN + PointsVP
    If poste13NonR <= limite Then
        Mon_Tableau(2, 13) = poste13NonR
    Else
        Mon_Tableau(2, 13) = Abs((Left(poste13NonR, 1) * 1 + Right(poste13NonR, 1) * 1))
    End If
        Cells(17, 3).Value = Mon_Tableau(2, 13)

'POSTE 14 : Poste12+poste13
'=======================================================================================================
poste14NR = Mon_Tableau(2, 12) + Mon_Tableau(2, 13)
    If poste14NR <= limite Then
        Mon_Tableau(2, 14) = poste14NR
    Else
        Mon_Tableau(2, 14) = Abs((Left(poste14NR, 1) * 1 + Right(poste14NR, 1) * 1))
    End If
        Cells(18, 3).Value = Mon_Tableau(2, 14)
'POSTE 15 : total lettres prénom
'======================================================================================================
    PointsVP = Voyelles(prenom)
    PointsCP = Consonnes(prenom)

    poste15NR = PointsVP + PointsCP
    If poste15NR <= limite Then
        Mon_Tableau(2, 15) = poste15NR
    Else
        Mon_Tableau(2, 15) = Abs((Left(poste15NR, 1) * 1 + Right(poste15NR, 1) * 1))
    End If
        Cells(19, 3).Value = Mon_Tableau(2, 15)
'POSTE 16 : poste5 et poste14
'=======================================================================================================
    poste16NR = Mon_Tableau(2, 14) + Mon_Tableau(2, 5)
    If poste16NR <= limite Then
        Mon_Tableau(2, 16) = poste16NR
    Else
        Mon_Tableau(2, 16) = Abs((Left(poste16NR, 1) * 1 + Right(poste16NR, 1) * 1))
    End If
        Cells(20, 3).Value = Mon_Tableau(2, 16)

'POSTE 17 : somme poste 10 a poste 16
'=======================================================================================================
poste17NR = Mon_Tableau(2, 10) + Mon_Tableau(2, 11) + Mon_Tableau(2, 12) + Mon_Tableau(2, 13) + Mon_Tableau(2, 14) + Mon_Tableau(2, 15) + Mon_Tableau(2, 16)
    If poste17NR <= limite Then
        Mon_Tableau(2, 17) = poste17NR
    Else
        Mon_Tableau(2, 17) = Abs((Left(poste17NR, 1) * 1 + Right(poste17NR, 1) * 1))
    'juste pour s'arrêter, on supprime apres
    'arret = Cells(1, 1).Value
    End If
        Cells(21, 3).Value = Mon_Tableau(2, 17)
'Les3piliers
'======================================================================================================




'rajout d'un 0 au jour s'il n'a qu'un chiffre
    If Len(jourR) < 2 Then
    jourR = "0" & jourR
    End If
        'rajout d'un 0 au mois s'il n'a qu'un chiffre
        If Len(moisn) < 2 Then
        moisn = "0" & moisn
        End If
            'rajout d'un 0 a l'annee si elle n'a qu'un chiffre
            If Len(anneeR) < 2 Then
            anneeR = "0" & anneeR
            End If
     
    'Les3Piliers = "0" & jourR & " & " & "0" & moisn & " & " & "0" & anneeR


    Les3Piliers = jourR & " & " & moisn & " & " & anneeR
 
Cells(4, 3).Value = Les3Piliers
'
' Recape Chapitre 1 : calcul des postes (Doublons, Triples, Etc.)
    ' Recherche des doublon
        DoublonTriplonEtc Mon_Tableau

    ' Copie vers excel
        FDouTriQuad.Cells(1,1) = "Chapitre 1"
        FDouTriQuad.Cells(2,1) = "Poste":FDouTriQuad.Cells(2,2) = "Valeur":FDouTriQuad.Cells(2,3) = "Occurence"
        CopieXls Mon_Tableau, 0, FDouTriQuad

'======================================================================================================
'Chapitre 2  : calcul de l'IKIGAI
''======================================================================================================
    'archives intérieures : poste2 + poste 4

    archintNR = Mon_Tableau(2, 2) + Mon_Tableau(2, 4)

    If archintNR <= limite Then
        archint = archintNR
    Else
        archint = Abs((Left(archintNR, 1) * 1 + Right(archintNR, 1) * 1))
    End If
        Cells(26, 3).Value = archint

'=======================================================================================================
    'Le don : poste1 + poste9 + poste 12
    LeDonNR = Mon_Tableau(2, 1) + Mon_Tableau(2, 9) + Mon_Tableau(2, 12)
    If LeDonNR <= limite Then
        LeDon = LeDonNR
    Else
        LeDon = Abs((Left(LeDonNR, 1) * 1 + Right(LeDonNR, 1) * 1))
    End If
        Cells(27, 3).Value = LeDon

'=======================================================================================================
    'l'inclinaison : poste9 + poste11 + poste 13
    LinclinaisonNR = Mon_Tableau(2, 9) + Mon_Tableau(2, 11) + Mon_Tableau(2, 13)
    If LinclinaisonNR <= limite Then
        Linclinaison = LinclinaisonNR
    Else
        Linclinaison = Abs((Left(LinclinaisonNR, 1) * 1 + Right(LinclinaisonNR, 1) * 1))
    End If
        Cells(28, 3).Value = Linclinaison

'=======================================================================================================
'reconnaissance du monde : poste6+poste 17
    RecMondeNR = Mon_Tableau(2, 6) + Mon_Tableau(2, 17)
    If RecMondeNR <= limite Then
        RecMonde = RecMondeNR
    Else
        RecMonde = Abs((Left(RecMondeNR, 1) * 1 + Right(RecMondeNR, 1) * 1))
    End If
        Cells(29, 3).Value = RecMonde

'=======================================================================================================
'ma juste place : archivesintérieures+le don+l'inclinaison+reconnaissance du monde
    MaJustePlaceNR = archint + LeDon + Linclinaison + RecMonde
    If MaJustePlaceNR <= limite Then
        MaJustePlace = MaJustePlaceNR
    Else
        MaJustePlace = Abs((Left(MaJustePlaceNR, 1) * 1 + Right(MaJustePlaceNR, 1) * 1))
    End If
        Cells(30, 3).Value = MaJustePlace

'=======================================================================================================
'l'accomplissement de l'oeuvre : poste1+poste6
    AccompoeuvreNR = Mon_Tableau(2, 1) + Mon_Tableau(2, 6)
    If AccompoeuvreNR <= limite Then
        Accompoeuvre = AccompoeuvreNR
    Else
        Accompoeuvre = Abs((Left(AccompoeuvreNR, 1) * 1 + Right(AccompoeuvreNR, 1) * 1))
    End If
        Cells(33, 3).Value = Accompoeuvre

'=======================================================================================================
'l'ancrage : poste3+poste10

    LancrageNR = Mon_Tableau(2, 3) + Mon_Tableau(2, 10)
    If LancrageNR <= limite Then
        Lancrage = LancrageNR
 
    Else
        Lancrage = Abs((Left(LancrageNR, 1) * 1 + Right(LancrageNR, 1) * 1))
    End If
        Cells(34, 3).Value = Lancrage

'=======================================================================================================
'arcane cle :   poste7 + poste8
    ArcaneCleNR = Mon_Tableau(2, 7) + Mon_Tableau(2, 8)
    If ArcaneCleNR <= limite Then
        ArcaneCle = ArcaneCleNR
    Else
        ArcaneCle = Abs((Left(ArcaneCleNR, 1) * 1 + Right(ArcaneCleNR, 1) * 1))
    End If
        Cells(35, 3).Value = ArcaneCle

'=======================================================================================================
'la tyrolienne d'incarnation : poste3-poste17
'bizarre, ça fait 0 !!!

    TyrolincarnNR = Mon_Tableau(2, 3) - Mon_Tableau(2, 17)
    If TyrolincarnNR <= limite Then
        Tyrolincarn = Abs(TyrolincarnNR)
    Else
        Tyrolincarn = Abs((Left(TyrolincarnNR, 1) * 1 + Right(TyrolincarnNR, 1) * 1))
    End If
        Cells(36, 3).Value = Tyrolincarn

'=======================================================================================================
    'l'envol : poste1+poste4
    EnvolNR = Mon_Tableau(2, 1) + Mon_Tableau(2, 4)

    If EnvolNR <= limite Then
        Envol = Abs(EnvolNR)
    Else
        Envol = Abs((Left(EnvolNR, 1) * 1 + Right(EnvolNR, 1) * 1))
    End If
        Cells(38, 3).Value = Envol

' Recape Chapitre 2 : calcul des postes (Doublons, Triples, Etc.)
    ' Recherche des doublon
        DoublonTriplonEtc Mon_Tableau

    ' Copie vers excel
        FDouTriQuad.Cells(1,5) = "Chapitre 2"
        FDouTriQuad.Cells(2,5) = "Poste":FDouTriQuad.Cells(2,6) = "Valeur":FDouTriQuad.Cells(2,7) = "Occurence"
        CopieXls Mon_Tableau, 4, FDouTriQuad

'=======================================================================================================
'Chapitre 3: les Champs Magnetiques
'=======================================================================================================
'meteor1 : Bateleur et Maison Dieu (1 et 16)
'meteor2 : papesse et diable Dieu (2 et 15)
'meteor3 : papesse et diable Dieu (3 et 14)
'meteor4 : Bateleur et Maison Dieu (4 et 13)
'meteor5 : pape et pendu (5 et 12)
'meteor6 : amoureux et force (6 et 11)
'meteor7 : chariot et roue de la fortune (7 et 10)
'meteor8 : justice et ermite (8 et 9)



    Tableau_arcanes = Array(Mon_Tableau(2, 1), Mon_Tableau(2, 2), Mon_Tableau(2, 3), Mon_Tableau(2, 4), Mon_Tableau(2, 5), Mon_Tableau(2, 6), Mon_Tableau(2, 7), Mon_Tableau(2, 8), Mon_Tableau(2, 9), Mon_Tableau(2, 10), Mon_Tableau(2, 11), Mon_Tableau(2, 12), Mon_Tableau(2, 13), Mon_Tableau(2, 14), Mon_Tableau(2, 15), Mon_Tableau(2, 16), Mon_Tableau(2, 17), archint, LeDon, Linclinaison, RecMonde, MaJustePlace, Accompoeuvre, Tyrolincarn, Lancrage, ArcaneCle, Envol)

For i = LBound(Tableau_arcanes) To UBound(Tableau_arcanes)
    For j = LBound(Tableau_arcanes) To UBound(Tableau_arcanes)
    'METEORES
        If Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 1 Then
        Cells(49, 2).Value = "Bateleur + Maison Dieu"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 15 Or Tableau_arcanes(j) = 15 And Tableau_arcanes(i) = 2 Then
        Cells(50, 2).Value = "Papesse + Diable" 'meteores
        Cells(74, 2).Value = "Diable + Papesse" 'failles
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 14 Or Tableau_arcanes(j) = 14 And Tableau_arcanes(i) = 3 Then
        Cells(51, 2).Value = "Impératrice + Tempérance"
        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 13 Or Tableau_arcanes(j) = 13 And Tableau_arcanes(i) = 4 Then
        Cells(52, 2).Value = "Empereur + Sans Nom"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 5 Then
        Cells(53, 2).Value = "Pape + Le Pendu"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 6 Then
        Cells(54, 2).Value = "Amoureux + Force"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 10 Or Tableau_arcanes(j) = 10 And Tableau_arcanes(i) = 7 Then
        Cells(55, 2).Value = "Chariot + Roue de La Fortune"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 9 Or Tableau_arcanes(j) = 9 And Tableau_arcanes(i) = 8 Then
        Cells(56, 2).Value = "Justice + Ermite"
    'INTEGRITE
        ElseIf Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 1 Then
        Cells(59, 2).Value = "Bateleur + Pendu"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 2 Then
        Cells(60, 2).Value = "Papesse + Force"
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 10 Or Tableau_arcanes(j) = 10 And Tableau_arcanes(i) = 3 Then
        Cells(61, 2).Value = "Impératrice + Roue de Fortune"
        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 9 Or Tableau_arcanes(j) = 9 And Tableau_arcanes(i) = 4 Then
        Cells(62, 2).Value = "Empereur + Ermite"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 8 Or Tableau_arcanes(j) = 8 And Tableau_arcanes(i) = 5 Then
        Cells(63, 2).Value = "Pape + Justice"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 7 Or Tableau_arcanes(j) = 7 And Tableau_arcanes(i) = 6 Then
        Cells(64, 2).Value = "Amoureux + Chariot"
     'LES FAILLES
        ElseIf Tableau_arcanes(i) = 9 And Tableau_arcanes(j) = 22 Or Tableau_arcanes(j) = 22 And Tableau_arcanes(i) = 9 Then
        Cells(67, 2).Value = "Mat + Ermite"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 21 Or Tableau_arcanes(j) = 21 And Tableau_arcanes(i) = 8 Then
        Cells(68, 2).Value = "Monde + Justice"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 20 Or Tableau_arcanes(j) = 20 And Tableau_arcanes(i) = 7 Then
        Cells(69, 2).Value = "Jugement + Chariot"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 19 Or Tableau_arcanes(j) = 19 And Tableau_arcanes(i) = 6 Then
        Cells(70, 2).Value = "Soleil + Amoureux"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 18 Or Tableau_arcanes(j) = 18 And Tableau_arcanes(i) = 5 Then
        Cells(71, 2).Value = "Lune + Pape"
        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 17 Or Tableau_arcanes(j) = 17 And Tableau_arcanes(i) = 4 Then
        Cells(72, 2).Value = "Etoile + Empereur" 'Pour les failles
        Cells(102, 2).Value = "Empereur + Etoile" 'Pour le tour du monde
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 3 Then
        Cells(73, 2).Value = "Impératrice + Maison Dieu" 'les failles
        Cells(79, 2).Value = "Impératrice + Maison Dieu"
'        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 15 Or Tableau_arcanes(j) = 15 And Tableau_arcanes(i) = 2 Then
'        Cells(74, 2).Value = "Diable + Papesse"
    'LE POUVOIR CREATEUR
        ElseIf Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 18 Or Tableau_arcanes(j) = 18 And Tableau_arcanes(i) = 1 Then
        Cells(77, 2).Value = "Bateleur + Lune"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 17 Or Tableau_arcanes(j) = 17 And Tableau_arcanes(i) = 2 Then
        Cells(78, 2).Value = "Papesse + Etoile"
'        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 3 Then
'        Cells(79, 2).Value = "Impératrice + Maison Dieu"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 14 Or Tableau_arcanes(j) = 14 And Tableau_arcanes(i) = 5 Then
        Cells(80, 2).Value = "Pape + Tempérance"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 13 Or Tableau_arcanes(j) = 13 And Tableau_arcanes(i) = 6 Then
        Cells(81, 2).Value = "Amoureux + Sans Nom"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 7 Then
        Cells(82, 2).Value = "Chariot + Pendu"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 8 Then
        Cells(83, 2).Value = "Justice + Force"
        ElseIf Tableau_arcanes(i) = 9 And Tableau_arcanes(j) = 10 Or Tableau_arcanes(j) = 10 And Tableau_arcanes(i) = 9 Then
        Cells(84, 2).Value = "Ermite + Roue de Fortune"
 
    'LA REVELATION
        ElseIf Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 19 Or Tableau_arcanes(j) = 19 And Tableau_arcanes(i) = 1 Then
        Cells(87, 2).Value = "Bateleur + Soleil"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 18 Or Tableau_arcanes(j) = 18 And Tableau_arcanes(i) = 2 Then
        Cells(88, 2).Value = "Papesse + Lune"
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 17 Or Tableau_arcanes(j) = 17 And Tableau_arcanes(i) = 3 Then
        Cells(89, 2).Value = "Impératrice + Etoile"
        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 4 Then
        Cells(90, 2).Value = "Empereur + Maison Dieu"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 15 Or Tableau_arcanes(j) = 15 And Tableau_arcanes(i) = 5 Then
        Cells(91, 2).Value = "Pape + Diable"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 14 Or Tableau_arcanes(j) = 14 And Tableau_arcanes(i) = 6 Then
        Cells(92, 2).Value = "Amoureux + Tempérance"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 13 Or Tableau_arcanes(j) = 13 And Tableau_arcanes(i) = 7 Then
        Cells(93, 2).Value = "Chariot + Sans Nom"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 8 Then
        Cells(94, 2).Value = "Justice + Pendu"
        ElseIf Tableau_arcanes(i) = 9 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 9 Then
        Cells(95, 2).Value = "Force + Ermite"
        ElseIf Tableau_arcanes(i) = 10 Then
        Cells(96, 2).Value = "Roue de Fortune"
 
    'LE TOUR DU MONDE
        ElseIf Tableau_arcanes(i) = 1 And Tableau_arcanes(j) = 20 Or Tableau_arcanes(j) = 20 And Tableau_arcanes(i) = 1 Then
        Cells(99, 2).Value = "Bateleur + Jugement"
        ElseIf Tableau_arcanes(i) = 2 And Tableau_arcanes(j) = 19 Or Tableau_arcanes(j) = 19 And Tableau_arcanes(i) = 2 Then
        Cells(100, 2).Value = "Papesse = Soleil"
        ElseIf Tableau_arcanes(i) = 3 And Tableau_arcanes(j) = 18 Or Tableau_arcanes(j) = 18 And Tableau_arcanes(i) = 3 Then
        Cells(101, 2).Value = "Impératrice + Lune"
'        ElseIf Tableau_arcanes(i) = 4 And Tableau_arcanes(j) = 17 Or Tableau_arcanes(j) = 4 And Tableau_arcanes(i) = 17 Then
'        Cells(102, 2).Value = "Empereur + Etoile"
        ElseIf Tableau_arcanes(i) = 5 And Tableau_arcanes(j) = 16 Or Tableau_arcanes(j) = 16 And Tableau_arcanes(i) = 5 Then
        Cells(103, 2).Value = "Pape + Maison Dieu"
        ElseIf Tableau_arcanes(i) = 6 And Tableau_arcanes(j) = 15 Or Tableau_arcanes(j) = 15 And Tableau_arcanes(i) = 6 Then
        Cells(104, 2).Value = "Amoureux + Diable"
        ElseIf Tableau_arcanes(i) = 7 And Tableau_arcanes(j) = 14 Or Tableau_arcanes(j) = 14 And Tableau_arcanes(i) = 7 Then
        Cells(105, 2).Value = "Chariot + Tempérance"
        ElseIf Tableau_arcanes(i) = 8 And Tableau_arcanes(j) = 13 Or Tableau_arcanes(j) = 13 And Tableau_arcanes(i) = 8 Then
        Cells(106, 2).Value = "Justice + Sans Nom"
        ElseIf Tableau_arcanes(i) = 9 And Tableau_arcanes(j) = 12 Or Tableau_arcanes(j) = 12 And Tableau_arcanes(i) = 9 Then
        Cells(107, 2).Value = "Ermite + Pendu"
        ElseIf Tableau_arcanes(i) = 10 And Tableau_arcanes(j) = 11 Or Tableau_arcanes(j) = 11 And Tableau_arcanes(i) = 10 Then
        Cells(108, 2).Value = "Roue de Fortune + Force"
        End If
    Next j
Next i

' Recape Chapitre 3" : calcul des postes (Doublons, Triples, Etc.)
    ' Recherche des doublon
        DoublonTriplonEtc Mon_Tableau

    ' Copie vers excel
        FDouTriQuad.Cells(1,9) = "Chapitre 3"
        FDouTriQuad.Cells(2,9) = "Poste":FDouTriQuad.Cells(2,10) = "Valeur":FDouTriQuad.Cells(2,11) = "Occurence"
        CopieXls Mon_Tableau, 8, FDouTriQuad

'Chapitre 4 : La création de l'étoile évolutive
'==============================================================================================================================
'Insertion des images d'arcanes dans la feuille EE
Sheets("EE").Activate

'Le chemin  = "C:\Users\JTMQ6376\Desktop\testetoile\arcane" sera à changer
'les postes 7 et 8 ne sont pas définis et l'image 22 est mise pour la bonne marche de la macro
Mon_Tableau(2, 7) = 22
Mon_Tableau(2, 8) = 22

  For Each Img In ActiveSheet.Pictures: Img.Delete: Next Img

  '22 arcanes ; si non utilisé : mettre 0

  '          1           2       3      4       5       6       7    8      9       10          11      12      13      14          15      16      17      18 19 20 21 22
  po = Array(Mon_Tableau(2, 1), Mon_Tableau(2, 2), Mon_Tableau(2, 3), Mon_Tableau(2, 4), Mon_Tableau(2, 5), Mon_Tableau(2, 6), Mon_Tableau(2, 7), Mon_Tableau(2, 8), Mon_Tableau(2, 9), Mon_Tableau(2, 10), Mon_Tableau(2, 11), Mon_Tableau(2, 12), Mon_Tableau(2, 13), Mon_Tableau(2, 14), Mon_Tableau(2, 15), Mon_Tableau(2, 16), Mon_Tableau(2, 17), 0, 0, 0, 0, 0)

  '            1  2    3  4    5    6    7    8    9   10   11   12   13   14   15   16   17 18 19 20 21 22
  pg = Array(167, 2, 385, 0, 665, 842, 838, 665, 166, 467, 467, 467, 467, 467, 467, 467, 385, 0, 0, 0, 0, 0)

  '             1    2     3    4     5    6    7    8    9    10    11   12   13   14   15   16 17 18 19 20 21 22
  ph = Array(1269, 988, 1417, 460, 1263, 985, 462, 268, 266, 1138, 1001, 860, 719, 575, 429, 285, 4, 0, 0, 0, 0, 0)

  For i = 1 To 22
    k = i - 1 'car pour les 3 arrays po, pg, ph : c'est à partir de 0, pas à partir de 1
    If po(k) > 0 Then ActiveSheet.Shapes.AddPicture Filename:=fp & po(k) & ".jpg", linktofile:=msoFalse, savewithdocument:=msoTrue, _
      Left:=pg(k), Top:=ph(k), Width:=100, Height:=140
  Next i

Sheets("Calculs").Activate
Cells(1, 1).Select


'=======================================================================================================
'arret = Cells(1, 1).Value 'a supprimer apres
Sheets("Calculs").Protect
Sheets("EE").Protect
End Sub
Function Voyelles(injectionV)
Dim PointsV

nbcarnom = Len(injectionV)
Voyelles = 0
For compteur = 1 To nbcarnom
lettreselect = Mid(injectionV, compteur, 1)
Lpoints = 0
Select Case lettreselect
    Case Is = "a"
    Lpoints = 1
    Case Is = "e"
    Lpoints = 5
    Case Is = "i"
    Lpoints = 9
    Case Is = "o"
    Lpoints = 6
    Case Is = "u"
    Lpoints = 3
    Case Is = "y"
    Lpoints = 7
End Select
Voyelles = Voyelles + Lpoints
Next compteur
End Function

Function Consonnes(injectionC)
Dim PointsC

'nom = Cells(2, 3).Value
nbcarnom = Len(injectionC)
Consonnes = 0
    For compteur = 1 To nbcarnom
    lettreselect = Mid(injectionC, compteur, 1)
    Lpoints = 0
        Select Case lettreselect
            Case Is = "b"
                Lpoints = 2
            Case Is = "c"
                Lpoints = 3
            Case Is = "d"
                Lpoints = 4
            Case Is = "f"
                Lpoints = 6
            Case Is = "g"
                Lpoints = 7
            Case Is = "h"
                Lpoints = 8
            Case Is = "j"
                Lpoints = 1
            Case Is = "k"
                Lpoints = 2
            Case Is = "l"
                Lpoints = 3
            Case Is = "m"
                Lpoints = 4
            Case Is = "n"
                Lpoints = 5
            Case Is = "p"
                Lpoints = 7
            Case Is = "q"
                Lpoints = 8
            Case Is = "r"
                Lpoints = 9
            Case Is = "s"
                Lpoints = 1
            Case Is = "t"
                Lpoints = 2
            Case Is = "v"
                Lpoints = 4
            Case Is = "w"
                Lpoints = 5
            Case Is = "x"
                Lpoints = 6
            Case Is = "z"
                Lpoints = 8
        End Select
        Consonnes = Consonnes + Lpoints
    Next compteur
End Function
Function in_array(tableau, recherche)

    'https://www.excel-pratique.com/fr/astuces_vba/recherche-tableau-array

    in_array = False

    For i = LBound(tableau) To UBound(tableau)
        If tableau(i) = recherche Then 'Si valeur trouvée
            in_array = True
            Exit For
        End If
    Next

End Function

Sub FeuilleDoubleTripleQuadruple()
    'ajouter une nouvelle Feuille à la fin du Classeur et la nommer
    If Worksheets(1).Name <> "FDouTriQuad" Then
        Sheets.Add(Before:=Worksheets(1)).Name = "FDouTriQuad"
    End If
End Sub

Sub DoublonTriplonEtc(Mon_Tableau() As Variant)
' recherche des doublons des variable existante :
Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = TextCompare
Dim cef As String
' transpose
Mon_Tableau = Application.Transpose(Mon_Tableau)
    For i = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
        clef = Mon_Tableau(i, 2)
        If d.Exists(clef) Then
            cpt = d(clef)
            If Mon_Tableau(i, 1) <> "" Then
                Mon_Tableau(cpt, 1) = Mon_Tableau(cpt, 1) & "-" & Mon_Tableau(i, 1)
            End If
                Mon_Tableau(cpt, 3) = Mon_Tableau(cpt, 3) + 1
                Mon_Tableau(i, 1) = ""
                        For j = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
                            If Mon_Tableau(cpt, 2) = Mon_Tableau(j, 2) Then
                                If Mon_Tableau(i, 1) <> "" Then
                                    Mon_Tableau(j, 3) = Mon_Tableau(cpt, 3)
                                End If
                            End If
                        Next j
        Else
            cpt = i 'd.Count + 1
            d(clef) = cpt
                Mon_Tableau(i, 3) = 1
        End If
    Next i
End Sub

Sub CopieXls(Mon_Tableau() As Variant, Col as integer, FDouTriQuad as worksheet)
Dim Lig As Integer: Lig = 3
' Etats des Variable en avec ou sans doublons dans la Feuille excel :
For i = LBound(Mon_Tableau, 1) To UBound(Mon_Tableau, 1)
    For j = LBound(Mon_Tableau, 2) To UBound(Mon_Tableau, 2)
        If Mon_Tableau(i, 1) <> "" Then
            FDouTriQuad.Cells(Lig, j + Col) = Mon_Tableau(i, j)
                  If j = 3 Then Lig = Lig + 1
        End If
    Next j
Next i

' transpose
    Mon_Tableau = Application.Transpose(Mon_Tableau)
        ReDim Preserve Mon_Tableau(1 To 3, 1 To UBound(Mon_Tableau, 2) + 1)
End Sub

Phillip · 26 Novembre 2020

Merci ! Je teste et te dis !

Cordialement

Phillip · 26 Novembre 2020

La macro plante car dans la sub Sub DoublonTriplonEtc(Mon_Tableau()

VB:

Else
            cpt = i 'd.Count + 1
            d(clef) = cpt
                Mon_Tableau(i, 3) = 1

Génère l'erreur : l'indice n'appartient pas à la sélection...

laurent950 · 26 Novembre 2020

je regarde
j'ai corrigé le code en Poste #26

Phillip · 26 Novembre 2020

Ca ne plante plus, mais ça me copie 3 fois chapitre3 sur la feuille, au lieu de chapitre1, 2 et 3....

Effectuez une recherche sur Excel Downloads...

XL 2016 VBA : trouver doublons, triplons, quadruplons, etc...

Phillip

XLDnaute Occasionnel

laurent950

XLDnaute Accro

laurent950

XLDnaute Accro

Phillip

XLDnaute Occasionnel

Phillip

XLDnaute Occasionnel

laurent950

XLDnaute Accro

Phillip

XLDnaute Occasionnel

laurent950

XLDnaute Accro

Phillip

XLDnaute Occasionnel

laurent950

XLDnaute Accro

Phillip

XLDnaute Occasionnel

laurent950

XLDnaute Accro

Phillip

XLDnaute Occasionnel

Phillip

XLDnaute Occasionnel

laurent950

XLDnaute Accro

Phillip

XLDnaute Occasionnel

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums