Calcul en VBA puis écriture dans une cellule (puis plage de celulle)

Merci Steelson ! Ça fonctionne très bien pour le transpose. Si je devais le trier par ordre alphabétique je devrais mettre quoi du coup ?

Par contre le calcul exotique ^^ lui ne me retourne aucune valeur. J'ai vérifié les colonnes, tout semble bien aller ...

Merci infiniment !

Enlève l'apostrophe devant le debug.print et ouvre la fenêtre d'exécution dans l'éditeur de macro pour voir ...

Je vais regarder pour trier les clés du dico

Pour le tri des cantons

Sub Listecanton()
    donnees = Sheets("BD_DE_123678").Range("L2:L" & Sheets("BD_DE_123678").Range("L" & Rows.Count).End(xlUp).Row)
    Set mondico = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(donnees)
        mondico(donnees(i, 1)) = ""
    Next
    ' transfert dans un tableau des clés pour tri
    tbl = mondico.keys
    QuickSort tbl

    Sheets("TB_Diag").Cells(2, 28).Resize(1, UBound(tbl)) = tbl
End Sub

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Damien C a écrit :

Par contre le calcul exotique ^^ lui ne me retourne aucune valeur. J'ai vérifié les colonnes, tout semble bien aller ...

On trouve bien les ROME disséminés dans le texte, mais rien n'est affecté en effet aux ROME de Tb_diag !!!

Je regarde.

Je suspecte une ambiguïté entre valeur et objet ... donc j'ai tout forcé en string

Sub calculerDE()
Dim compteurDE As Object, resultatDE(), obj As Object, txt As String

    ' chargement des données
    donneesDE = Sheets("BD_DE_123678").Range("A1").CurrentRegion.Value
    ' ROME colonne 14

    Set obj = CreateObject("vbscript.regexp")
    obj.Pattern = "[A-Z][0-9]{4}"
    obj.Global = True

    ' comptage
    Set compteurDE = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(donneesDE)
        Set tbl = obj.Execute(donneesDE(i, 14))
        For j = 0 To tbl.Count - 1
            txt = tbl(j)
            compteurDE(txt) = compteurDE(txt) + 1
            'Debug.Print "|" & txt & "|"
        Next
    Next

    ' chargement des données et récupération du décompte
    romeDE = Sheets("TB_Diag").Range("B3:B" & Sheets("TB_Diag").Range("B" & Rows.Count).End(xlUp).Row).Value
    ReDim resultatDE(1 To UBound(romeDE) - 1)
    For i = 1 To UBound(romeDE) - 1
        txt = romeDE(i, 1)
        resultatDE(i) = compteurDE(txt)
        'Debug.Print i, "|" & txt & "|", compteurDE(txt)
    Next

    ' tranfert du résultat
    Sheets("TB_Diag").Range("X3").Resize(UBound(resultatDE), 1) = WorksheetFunction.Transpose(resultatDE)

End Sub

Bonjour Steelson !

Je rentre du boulot et je vois que ça fonctionne c'est super génial pour ton aide ! J'ai juste un regret c'est que la macro calculerDE met 63 secondes à calculer pour seulement 4500 lignes ce qui ne rend pas jouable l'utilisation du code avec une base qui peut faire bien plus... j'aurai utilisé ce code pour ajuster les colonnes des cantons.

Si tu as une idée de génie je suis preneur ou sinon faut que je vois si je dois pas faire un choix dans les informations que j'affiche et me restreindre au métier1 ORE

En parlant d'idée de génie j'ai dans mon fichier un bouton d'appel pour réaliser un filtre élaboré qui marche très bien.

Par contre comme je peux augmenter la base de donnée je me rends compte que vers 30 000 lignes, il gère plus et renvoi une erreur de type 6.

Existe-t-il un moyen de contourner ce problème ?

Voici mon code :

Sub Export()

Dim DerLig As Integer

Worksheets("CRITERE_DE").UsedRange.Columns("E:V").Calculate

DerLig = Sheets("BD_DE_123678").Range("a" & Rows.Count).End(xlUp).Row

Call Sup_HyperLien

Range("BD_DE_123678!$A$1:$AC$" & DerLig).AdvancedFilter _

         Action:=xlFilterCopy, _

         CriteriaRange:=Range("CRITERE_DE!$A$3:$V$4"), _

         CopyToRange:=Range("FILTRE_DE!$A$1:$w$1"), _

         Unique:=False

Call ins_HyperLien

With Range("FILTRE_DE!$A$2:$A$1000")

    .HorizontalAlignment = xlHAlignCenter 'ou xlHAlignLeft ou xlHAlignRight

    .VerticalAlignment = xlVAlignCenter 'ou xlVAlignTop ou xlVAlignBottom

     .Borders(xlEdgeTop).Weight = xlMedium    'haut

        .Borders(xlEdgeBottom).Weight = xlMedium 'bas

        .Borders(xlEdgeLeft).Weight = xlMedium   'gauche

        .Borders(xlEdgeRight).Weight = xlMedium  'droite

End With

  Sheets("FILTRE_DE").Activate

    Rows("1:1").Select

    Selection.AutoFilter

    Selection.AutoFilter

         End Sub

Essaie de définir DerLIg comme ceci

Dim DerLig As Long

Damien C a écrit :

e la macro calculerDE met 63 secondes à calculer pour seulement 4500 lignes

C'est sûr que, lorsque l'information amont n'est pas structurée, il faut balayer la zone. Je ne vois pas de moyen plus rapide aujourd'hui. A moins de pouvoir le faire en amont et de mettre dans une cellule toutes les valeurs de ROME avec un séparateur.

Dans combien de cas cela se produit ?

Bonjour Steelson, merci pour l'information en effet c'est Integer qui bloquait ... long admet plus de valeurs.

Ne t'embète pas pour trouver une solution j'ai finalement pris le parti aujourd'hui de continuer le dossier sans chercher la solution car l'information même si elle est bien n'est pas forcément la plus pertinente.

Du coup j'ai presque bouclé tout mon fichier MAIS il m'arrive un truc de fou.

La macro ci-dessous ne fonctionne plus comme à son origine C'est à dire qu'elle n'écrit plus les valeurs, c'est vide.
Pourtant, Elle fonctionne quand j'enleve la boucle et que je calcule que sur une colonne sans me déplacer.
Mais, le plus étrange c'est qu'elle fonctionne dans une copie du classeur et que j'ai beau essayer de comprendre, je ne vois pas ... il y a un mystère qui doit certainement venir de la valeur DernCol certainement mais pourquoi ça fonctionne dans un autre classeur ...

Je continue de chercher et de tenter de réécrire mais sans succès.

Dit moi, à en juger des heures auxquelles tu réponds, tu dois être du côté Québécois non ? Pays que j'aimerai visiter un jour avec ses grandes étendues sauvages :))))))

Sub calculerDEoreC1()

Dim compteurDECanton As Object, resultatDE()
Dim canton As String
Dim debut As Integer
Dim DernCol As Integer
DernCol = Cells(2, Cells.Columns.Count).End(xlToLeft).Column
romeDE = Sheets("TB Diag").Range("B3:B" & Sheets("TB Diag").Range("B" & Rows.Count).End(xlUp).Row).Value ' chargement des données
    donneesDE = Sheets("BD_DE_123678").Range("A1").CurrentRegion.Value
    ' ROME ORE colonne 13 | canton colonne 12
For debut = 26 To DernCol
    ' comptage
    Set compteurDECanton = CreateObject("Scripting.Dictionary")
    canton = Sheets("TB Diag").Cells(2, debut).Value
    For i = 2 To UBound(donneesDE)
            If donneesDE(i, 12) Like canton Then
            maCle = Replace(donneesDE(i, 13), "Non renseigné", "")
            maCle = Left(maCle, 5)
            compteurDECanton(maCle) = compteurDECanton(maCle) + 1
            End If
    Next

    ' chargement des données et récupération du décompte
    ReDim resultatDE(1 To UBound(romeDE) - 1)
    For i = 1 To UBound(romeDE) - 1
        resultatDE(i) = compteurDECanton(romeDE(i, 1))
    Next

    ' tranfert du résultat
    Sheets("TB Diag").Cells(3, debut).Resize(UBound(resultatDE), 1) = WorksheetFunction.Transpose(resultatDE)
Next
End Sub

Je ne suis pas loin du Québec en effet, mais en France métropolitaine quand même, juste sur le littoral atlantique !

Je regarderai cela un peu plus tard ... il y a un schmilblick en effet !

De quel onglet s'agit-il ?

DernCol = Cells(2, Cells.Columns.Count).End(xlToLeft).Column

Il manque l'espace souligné dans

 romeDE = Sheets("TB Diag").Range("B3:B" & Sheets("TB Diag").Range("B" & Rows.Count).End(xlUp).Row).Value

C'est TB_Diag et non TB Diag

ceci fonctionne (à partir de la colonne 28 sur l'un des fichiers que tu m'avais envoyé)

Sub calculerDEoreC1()

Dim compteurDECanton As Object, resultatDE()
Dim canton As String
Dim debut As Integer
Dim DernCol As Integer
DernCol = Sheets("TB_Diag").Cells(2, Cells.Columns.Count).End(xlToLeft).Column

    romeDE = Sheets("TB_Diag").Range("B3:B" & Sheets("TB_Diag").Range("B" & Rows.Count).End(xlUp).Row).Value
    donneesDE = Sheets("BD_DE_123678").Range("A1").CurrentRegion.Value
    ' ROME ORE colonne 13 | canton colonne 12
For debut = 28 To DernCol
    ' comptage
    Set compteurDECanton = CreateObject("Scripting.Dictionary")
    canton = Sheets("TB_Diag").Cells(2, debut).Value
    For i = 2 To UBound(donneesDE)
            If donneesDE(i, 12) Like canton Then
            maCle = Replace(donneesDE(i, 13), "Non renseigné", "")
            maCle = Left(maCle, 5)
            compteurDECanton(maCle) = compteurDECanton(maCle) + 1
            End If
    Next

    ' chargement des données et récupération du décompte
    ReDim resultatDE(1 To UBound(romeDE) - 1)
    For i = 1 To UBound(romeDE) - 1
        resultatDE(i) = compteurDECanton(romeDE(i, 1))
    Next

    ' tranfert du résultat
    Sheets("TB_Diag").Cells(3, debut).Resize(UBound(resultatDE), 1) = WorksheetFunction.Transpose(resultatDE)
Next
End Sub

Merci !!!

J'ai réussis par trouver et je ne sais pas comment mais l'essentiel c'est que ça fonctionne. J'ai finalisé le document qui maintenant sera opérationnel pour n'importe quel base importée. J'ai le cerveau en compote à force de tâtonner.

Un grand merci à toi pour tout ce temps et cette motivation que tu as apporté !

Je vais pouvoir m'endormir serein avec ce bébé tout frais et tout opérationnel :)

Bonjour Steelson,

A l'utilisation j'ai remarqué une erreur dans la liste des cantons qui est sortie g^race aux 2 procédures ci-dessous.

La dernière valeur de la liste alphabétique n'est pas affichée. Comment modifier cette macro pour que la dernière valeur de la liste soit prise en compte ?

Sub Listecanton()
Dim i As Long
Dim DerCol As Integer
DerCol = Sheets("TB Diag").Cells(2, Cells.Columns.Count).End(xlToLeft).Column
For i = 26 To DerCol
Columns(i).Delete
Next
    donnees = Sheets("BD_DE_123678").Range("L2:L" & Sheets("BD_DE_123678").Range("L" & Rows.Count).End(xlUp).Row)
    Set mondico = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(donnees)
        mondico(donnees(i, 1)) = ""
    Next
    ' transfert dans un tableau des clés pour tri
    tbl = mondico.keys
    QuickSort tbl

    Sheets("TB Diag").Cells(2, 26).Resize(1, UBound(tbl)) = tbl
End Sub

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Correction ...

Sub Listecanton()
Dim i As Long
Dim DerCol As Integer
DerCol = Sheets("TB Diag").Cells(2, Cells.Columns.Count).End(xlToLeft).Column
For i = 26 To DerCol
    Columns(i).Delete
Next

Dim tbl() As Variant, cle As Variant, cantons As Object
    donnees = Sheets("BD_DE_123678").Range("L2:L" & Sheets("BD_DE_123678").Range("L" & Rows.Count).End(xlUp).Row)
    Set cantons = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(donnees)
        cantons(donnees(i, 1)) = ""
    Next
    ' transfert dans un tableau des clés pour tri
    ReDim tbl(1 To cantons.Count)
    i = 1
    For Each cle In cantons
        tbl(i) = cle
        i = i + 1
    Next
    QuickSort tbl
    Sheets("test").Cells(2, 26).Resize(1, UBound(tbl)) = tbl
End Sub

Public Sub QuickSort(vArray As Variant, _
  Optional ByVal inLow As Long = -1, _
  Optional ByVal inHi As Long = -1)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  inLow = IIf(inLow = -1, LBound(vArray), inLow)
  inHi = IIf(inHi = -1, UBound(vArray), inHi)
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub