XL 2010 VBA Boucle pour faire mes entête de colonne

[jlbcall]

Bonjour à tous,

J'ai une base de données de la colonne A à AM
Je vais devoir valoriser ces données en les multipliant par un nombre de jours par mois.
Les mois se trouvant de la colonne AN à AY (12 mois).
Dans la première étape de ma marco je souhaiterais donc mettre des entêtes.
Je concatène donc le mois exemple Janvier avec les 18 colonnes dont j'ai besoin.
Pour le mois de Janvier ma macro fait cela ci dessous. Pour éviter de refaire les même formules pour les 11 autres mois je voudrais faire une boucle qui reprenne les même colonne mais avec le mois de Février , puis mars etc...
Je concatène à chaque fois le mois et les 18 autres colonnes
si quelqu'un peut me proposer une solution merci

Sub ValorisationUO()

Range("AZ1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-12],R1C18)"
Range("BA1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-13],R1C19)"
Range("Bb1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-14],R1C22)"
Range("BC1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-15],R1C23)"
Range("BD1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-16],R1C24)"
Range("BE1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-17],R1C25)"
Range("BF1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-18],R1C26)"
Range("BG1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-19],R1C27)"
Range("BH1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-20],R1C28)"
Range("BI1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-21],R1C29)"
Range("BJ1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-22],R1C30)"
Range("BK1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-23],R1C31)"
Range("BL1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-24],R1C32)"
Range("BM1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-25],R1C33)"
Range("BN1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-26],R1C33)"
Range("BN1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-26],R1C34)"
Range("BO1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-27],R1C35)"
Range("BP1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-28],R1C36)"
Range("BQ1").Select
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-29],R1C37)"
Range("AZ1").Select
End Sub

 

[jlbcall]

Bonjour Job 75 ,

Le fichiers est un exemple ma base de donnée est énorme et peut aller jusqu’à 25000 Lignes ,voir plus, suivants mes hypothèses de travail.
Les formules prennent beaucoup de place est mon fichier par moment plantait le VBA a permis de réduire la taille du fichier par 2 voir 3.
Dans les différents scénarii je dois pouvoir relancer les formules rapidement en les consolidant (copier coller valeurs) et les macros sont vraiment un atout. de plus dans certaines colonne il y a du texte qui doit prendre la valeur de "1" et comme je l'ai dis à Bruno sur d'autre je dois multiplier certaines valeurs par la colonne AL.

Merci quand même je garde ton fichier, je pense qu'il pourra m'être utile pour d'autre fichier, bonne finde journée jlbcall

 

[job75]

Re,

Pour régler le problème du post #11 (la colonne AL) on utilisera cette formule en AZ2 :

=INDEX($AN2:$AY2;1+ENT((COLONNES($AZ2:AZ2)-1)/18))*INDEX($R2:$AK2;INDEX(ColBase;1+MOD(COLONNES($AZ2:AZ2)-1;18)))*SI(MOD(COLONNES($AZ2:AZ2)-1;18)>3;$AL2;1)

Je montrerai dans mon prochain message comment utiliser cette formule en VBA.

Fichier (2).

A+

 

[job75]

Re,

Si l'on tient à utiliser du VBA on pourra tester cette macro très simple :

Sub Calculer()
If Application.CountA(Rows(2)) = 0 Then Exit Sub 'sécurité
With Intersect([A1].CurrentRegion, Range("AZ2:JG" & Rows.Count))
    .Formula = "=INDEX($AN2:$AY2,1+INT((COLUMNS($AZ2:AZ2)-1)/18))*INDEX($R2:$AK2,INDEX(ColBase,1+MOD(COLUMNS($AZ2:AZ2)-1,18)))*IF(MOD(COLUMNS($AZ2:AZ2)-1,18)>3,$AL2,1)"
    .Value = .Value 'supprime les formules
    .Rows(1).Offset(.Rows.Count).Resize(Rows.Count - .Rows.Count - 1).Delete xlUp 'RAZ en dessous
End With
End Sub

Fichier joint.

Avec 25000 lignes le fichier sera moins lourd mais le calcul des formules prendra forcément du temps.

Le fichier devrait peser environ 20 Mo...

A+

 

[job75]

Re,

Bon d'après mes tests l'utilisation des formules prend 4 fois plus de temps que la macro de Bruno.

Cette méthode n'est donc pas intéressante.

A+

 

[job75]

Re,

Mais si elle est intéressante !

En remplaçant dans les formules COLONNES($AZ1:AZ1)-1 par COLONNE()-52 le calcul est bien plus rapide.

Cette macro est maintenant 2 fois plus rapide chez moi que la macro de Bruno :

Sub Calculer()
If Application.CountA(Rows(2)) = 0 Then Exit Sub 'sécurité
With Intersect([A1].CurrentRegion, Range("AZ2:JG" & Rows.Count))
    .Formula = "=INDEX($AN2:$AY2,1+INT((COLUMN()-52)/18))*INDEX($R2:$AK2,INDEX(ColBase,1+MOD(COLUMN()-52,18)))*IF(MOD(COLUMN()-52,18)>3,$AL2,1)"
    .Value = .Value 'supprime les formules
    .Rows(1).Offset(.Rows.Count).Resize(Rows.Count - .Rows.Count - 1).Delete xlUp 'RAZ en dessous
End With
End Sub

Fichier (2).

A+

 

[job75]

Re,

Pour tester le fichier précédent j'ai copié les lignes 2:45 sur les lignes 2:30801, le poids du fichier est alors de 24 Mo.

La macro s'exécute chez moi en 106 secondes, c'est acceptable.

A+

 

[youky(BJ)]

Bonjour Job,
Je vois que tu t'ai pris au jeu aussi, surtout quand y a beaucoup de lignes.
La tu es dans ton élément, je n'ai pas encore regarder ton fichier ce que je vais faire de suite.
Tes formules utilisent elles toutes les contraintes….
Je mets aussi mon boulot sur le tapis.
Ma macro se fait en 2temps avec demande de l'année pour savoir si bissextile.
Je demande à Jibcali de bien vérifier sur une ligne d'un mois si tout est bon.
De AZ3:BQ3 si c'est bon c'est bon de partout
Bruno

 

[job75]

Bonjour jlbcall, Bruno, le forum,

Il est temps de passer aux choses sérieuses : pour aller vite il faut utiliser des tableaux VBA :

Sub Calculer()
Dim derlig&, basemois, base, multiplie, resu(), mois%, col%, j%, i&, njour
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
derlig = Cells(Rows.Count, 1).End(xlUp).Row
'---tableaux VBA, plus rapides---
basemois = [AN1].Resize(derlig, 12)
base = [R1].Resize(derlig, 20)
multiplie = [AL1].Resize(derlig)
ReDim resu(1 To derlig, 1 To 12 * 18)
'---calculs---
For mois = 1 To 12
    For col = 1 To 20
        If col = 3 Then col = 5
        j = j + 1
        resu(1, j) = basemois(1, mois) & base(1, col)
Next col, mois
For i = 2 To derlig
    j = 0
    For mois = 1 To 12
        njour = basemois(i, mois)
        For col = 1 To 20
            If col = 3 Then col = 5
            j = j + 1
            If IsNumeric(base(i, col)) Then resu(i, j) = njour * base(i, col) * IIf(col > 6, multiplie(i, 1), 1)
Next col, mois, i
'---restitution---
[AZ1].Resize(derlig, j) = resu
[AZ1].Offset(derlig).Resize(Rows.Count - derlig, j).ClearContents 'RAZ en dessous
End Sub

Fichier (3).

Testé sur 30 801 lignes => chez moi la macro s'exécute en 12,5 secondes.

Bonne journée.

 

[jlbcall]

Ok merci Bruno, Job75 je regarde je test les deux derniers fichiers et vous tiens informé

 

[jlbcall]

Re,
Pour répondre à Bruno ;
Dans mon fichier les/le calendriers sont gérés dans un onglet à part ce qui me permets de savoir si février à 28 ou 29 jours.
Les différents type de jours sont donc ensuite importer sur l'onglet Data pour valoriser mes unités d'oeuvres.
J'ai testé ton fichier avec ta dernière macro les résultat sont correct mais l’exécution est un peu long.

Pour Job75:
La macro fonctionne en un temps record 6 secondes pour les 23378 lignes c'est assez impressionnant le fichier avec d’autres onglets fait 12 Mo et ne plante plus comme mes anciens fichiers.
J'ai une macro pour des calculs plus simple qui dure 57 secondes est il possible de la rendre plus rapide? voir ci desous

UN GRAND MERCI A TOUT LES DEUX vous m'avez beaucoup apporté passer une bonne journée

Sub NbrS1()
Dim t#, derlig&
t = Timer
With Sheets("Data")
.[AL1] = "S-Agent": .[AM1] = "S-Veh"
derlig = .UsedRange.Rows.Count
If derlig = 1 Then Exit Sub
.[AL2].Resize(derlig - 1) = "=1/COUNTIFS(A$2:A$" & derlig & ",A2,B$2:B$" & derlig & ",B2,G$2:G$" & derlig & ",G2)"
.[AM2].Resize(derlig - 1) = "=1/COUNTIFS(A$2:A$" & derlig & ",A2,E$2:E$" & derlig & ",E2,G$2:G$" & derlig & ",G2)"
.Range("Al2:am" & derlig) = .Range("Al2:am" & derlig).Value

End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

 

[job75]

Re,

J'ai une macro pour des calculs plus simple qui dure 57 secondes est il possible de la rendre plus rapide? voir ci desous

Oui en utilisant 2 tableaux VBA et 2 Dictionary :

Sub NbrS2()
Dim t#, h&, tablo, resu(), d1 As Object, d2 As Object, sep$, i&, x$, y$
t = Timer
With Sheets("Data")
    .[AL1] = "S-Agent": .[AM1] = "S-Veh"
    h = .UsedRange.Rows.Count - 1
    If h = 0 Then Exit Sub
    tablo = [A2].Resize(h, 7) 'colonnes A à G
    ReDim resu(1 To h, 1 To 4)
    Set d1 = CreateObject("Scripting.Dictionary")
    d1.CompareMode = vbTextCompare 'la casse est ignorée
    Set d2 = CreateObject("Scripting.Dictionary")
    d2.CompareMode = vbTextCompare 'la casse est ignorée
    sep = Chr(1) 'séparateur
    For i = 1 To h
        x = tablo(i, 1) & sep & tablo(i, 2) & sep & tablo(i, 7)
        y = tablo(i, 1) & sep & tablo(i, 5) & sep & tablo(i, 7)
        d1(x) = d1(x) + 1: resu(i, 3) = x 'compte et mémorise
        d2(y) = d2(y) + 1: resu(i, 4) = y 'compte et mémorise
    Next
    For i = 1 To h
        If tablo(i, 1) <> "" And tablo(i, 2) <> "" And tablo(i, 7) <> "" Then resu(i, 1) = 1 / d1(resu(i, 3))
        If tablo(i, 1) <> "" And tablo(i, 5) <> "" And tablo(i, 7) <> "" Then resu(i, 2) = 1 / d2(resu(i, 4))
    Next
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .[AL2].Resize(h, 2) = resu
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

La macro avec les formules renvoie #DIV/0! si une cellule en colonnes A B E G est vide.

Celle-ci laisse le résultat vide mais on peut facilement y mettre la valeur d'erreur si l'on préfère.

A+