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