Reduire code VBA et jusqu' aux dernières lignes non vide

Le 24/01/2020 à 10:02

Bonjour,

svp

j'ai crée ce code avec des enregistrements des macros

il est très long

je cherche à le réduire et qu' il soit efficace jusqu' aux dernières lignes non vide pour qu'il fonctionne sur d'autres fichiers

Merci infiniment

81.rar (860.03 Ko)
Le 24/01/2020 à 12:30

Bonjour Hicham, bonjour le forum,

Déjà tu peux supprimer tous les Scroll dont raffole l'enregistreur de macro mais qui ne servent à rien. Ensuite, la règle d'or en VBA c'est d'éviter tous les Select et autres Activate inutiles. Ils ne font que ralentir l'exécution du code et sont source de plantage.

Malheureusement dans ton code les onglets ne sont pas définis et ça complique.

Je te propose le code ci-dessous (à vérifier) :

Sub Macro1()
Dim F As FileDialog
Dim Doc1 As String, Doc2 As String
Dim WB1 As Workbook, WB1SH As Worksheet
Dim WB2 As Workbook, WB2SH As Worksheet, WB2Nom
Dim WB3 As Workbook, WB3SH As Worksheet, WB3Nom

Set WB1 = ThisWorkbook
Set WB1SH = WB1.Worksheets("Feuil2")
MsgBox "Merci d'ouvrir le fichier C.T AO", vbInformation, "HICHAM"
Set F = Application.FileDialog(msoFileDialogOpen)
With F
    F.Title = "Merci d'ouvrir le fichier C.T AO"
    .AllowMultiSelect = False
    .Filters.Add "Fichiers Excel", "*.xlsx", 1
    .Show
    On Error Resume Next
    F.Execute
    If Err <> 0 Then
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    Set WB2 = ActiveWorkbook
End With
UserForm1.Show
Set WB2SH = ActiveSheet

MsgBox "Merci d'ouvrir le fichier AO", vbInformation, "HICHAM"
Set F = Application.FileDialog(msoFileDialogOpen)
With F
    F.Title = "Merci d'ouvrir le fichier AO"
    .AllowMultiSelect = False
    .Filters.Add "Fichiers Excel", "*.xlsx", 1
    .Show
    On Error Resume Next
    F.Execute
    If Err <> 0 Then
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    Set WB3 = ActiveWorkbook
End With
UserForm1.Show
Set WB3SH = ActiveSheet

WB3SH.Cells.Copy WB1SH.Range("A1")
WB1.Worksheets("Feuil2").Rows("9:150").RowHeight = 15
WB2SH.Range("F7:F150").Copy
WB1SH.Range("G9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("G7:G150").Copy
WB1SH.Range("J9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("H7:H150").Copy
WB1SH.Range("M9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("I7:I150").Copy
WB1SH.Range("P9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("J7:J150").Copy
WB1SH.Range("S9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("K7:K150").Copy
WB1SH.Range("V9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("L7:L150").Copy
WB1SH.Range("Y9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB2SH.Range("M7:M150").Copy
WB1SH.Range("AB9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
WB1SH.Range("I9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-3]*RC[-1],"""")"
WB1SH.Range("I9").AutoFill Destination:=WB1SH.Range("I9:I78"), Type:=xlFillDefault
WB1SH.Range("I9:I78").Select
WB1SH.Range("I9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-3]*RC[-1],"""")"
WB1SH.Range("L9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-6]*RC[-1],"""")"
WB1SH.Range("L9").AutoFill Destination:=WB1SH.Range("L9:L78"), Type:=xlFillDefault
WB1SH.Range("L9:L78").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-6]*RC[-1],"""")"
WB1SH.Range("O9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-9]*RC[-1],"""")"
WB1SH.Range("O9").AutoFill Destination:=WB1SH.Range("O9:O78"), Type:=xlFillDefault
WB1SH.Range("O9:O78").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-9]*RC[-1],"""")"
WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC,"""")"
WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC,"""")"
WB1SH.Range("R9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-12]*RC[-1],"""")"
WB1SH.Range("R9").AutoFill Destination:=Range("R9:R78"), Type:=xlFillDefault
WB1SH.Range("U9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-15]*RC[-1],"""")"
WB1SH.Range("U9").AutoFill Destination:=Range("U9:U78"), Type:=xlFillDefault
WB1SH.Range("X9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-18]*RC[-1],"""")"
WB1SH.Range("X9").AutoFill Destination:=Range("X9:X78"), Type:=xlFillDefault
WB1SH.Range("AA9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-21]*RC[-1],"""")"
WB1SH.Range("AA9").AutoFill Destination:=Range("AA9:AA78"), Type:=xlFillDefault
WB1SH.Range("AD9").FormulaR1C1 = "=IF(RC[-2]=""c"",RC[-24]*RC[-1],"""")"
WB1SH.Range("AD9").AutoFill Destination:=Range("AD9:AD78"), Type:=xlFillDefault
End Sub

le Fichier :

5hicham-ep-v01.xlsm (28.76 Ko)
Le 24/01/2020 à 13:11

ThauThème

Merci infiniment

ET pour qu' il soit efficace jusqu' aux dernières lignes non vide pour qu'il fonctionne sur d'autres fichiers

Merci d'avance

Le 25/01/2020 à 11:04

Re,

En pièce jointe le fichier modifié pour fonctionner jusqu'à la dernière ligne non vide.

Après, avec d'autre fichiers, s'ils ont les mêmes besoins, ça devrait marcher aussi...

Le fichier :

3hicham-ep-v02.xlsm (22.74 Ko)
Le 25/01/2020 à 13:28

Bonjour ThauThème , bonjour le forum,

merci infiniment pour ton aide.

Rechercher des sujets similaires à "reduire code vba dernieres lignes vide"