Exécuter ma macro sur une feuille défini

I

Ibrahimi

XLDnaute Nouveau
Bonjour,

Mon problème c'est que j'ai une macro qui se lance sur mes 2 feuilles alors que je veux qu'elle se lance que sur la feuille 1.

Je ne sais pas comment faire pour l'empêcher qu'elle se lance sur la feuille 2.

Merci.
 
Trier par date Trier par votes
I

Ibrahimi

XLDnaute Nouveau
VB: 
Sub VOL_Hydro()


With Sheets(1)

     stepline = 4
   
    Myfilexls = ActiveWorkbook.FullName
longueurnom = InStr(1, Myfilexls, ".")
Myfile = Left(Myfilexls, longueurnom - 1)
Mypath = ActiveWorkbook.Path
    longueurpath = Len(Mypath)
mywin = Right(Myfilexls, (longueurnom - longueurpath + 2))
   


          'reponse = Application.Dialogs(xlDialogOpen).Show
   Windows(mywin).Activate

' affichage de toutes les lignes
    Cells.Select
    Selection.EntireRow.Hidden = False

' effacement des lignes dont la deuxième colonne est 'H'
    nligne = 1
    Range("A1").Select
    lignefin = Application.ActiveCell.SpecialCells(xlLastCell).Row
  Do While nligne < lignefin + 1
   Seleinit = Cells(nligne, 2).Value
 
   If Seleinit = "H" Then
     Rows(nligne).Select
     Selection.Delete
    lignefin = lignefin - 1
    Else
     nligne = nligne + 1
    End If
Loop

  'Remplacement de la colonne alphanu des poids par une colonne numérique
    Columns("I:I").Select
    Selection.Copy
    Columns("K:K").Select
    ActiveSheet.Paste
    Selection.Replace What:="kg", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
       
  'Remise de kg dans l'entete et suppression de la colonne originale des poids
    Range("K7").Select
    ActiveCell.FormulaR1C1 = "kg"
   
    Columns("K:K").Select
    Application.CutCopyMode = False
    Selection.Cut
    Columns("I:I").Select
    ActiveSheet.Paste
   
      'Ajout de la somme totale des poids
   nline = lignefin + 1
   locsomme = "I" & nligne
    Range(locsomme).Select
    retour = nligne - 8
    zonesomme = "=SUM(R[-" & retour & "]C:R[-1]C)"
    ActiveCell.FormulaR1C1 = zonesomme
   
        Cells.Select
    Range("D1").Activate
    Selection.EntireColumn.Hidden = False
    Columns("A:C").Select
    Selection.Delete Shift:=xlToLeft

    'suppression de l'entete
   
'   Rows("2:7").Select
    Rows("3:7").Select
    Selection.Delete Shift:=xlUp
    Rows("3:3").Select
    Selection.Insert Shift:=xlDown
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "VOLUME HYDRO"
    With ActiveCell.Characters(Start:=1, Length:=12).Font
        .Name = "Arial"
        .FontStyle = "Gras"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
   
    'Insertion d'une colonne
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
   

   
   ' Suppresion du mm dans la colonne longueur
    pos = "E" & stepline
    Range(pos).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Replace What:="mm", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
   
   
    'Recalcul du nombre de ligne
     
    pos = "C" & 1
    Range(pos).Select
    Selection.End(xlDown).Select
    lastline = ActiveCell.Row
   
     'Traitement des lignes ou la longueur est inférieure à 5 mm
    ' et arrondi de la valeur au 100 mm supérieur

    nligne = 4
    Range("A1").Select
  Do While nligne < lastline + 1
   longmm = Cells(nligne, 5).Value
 
   If longmm < 5 Then
    Rows(nligne & ":" & nligne).Select
    Selection.Delete Shift:=xlUp
    lastline = lastline - 1
    Else
     nligne = nligne + 1
    End If
   Loop
        'selection de la zone  à traiter
    rangetraite = stepline & ":" & lastline
    Rows(rangetraite).Select
   
    'Tri sur la colonne C (code article complet)
    pos = "C" & stepline
    Selection.Sort Key1:=Range(pos), Order1:=xlAscending, Header:=xlGuess, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
       DataOption1:=xlSortNormal
     
    'placement de la fonction exact en colonne B et extension surles lignes significatives
    pos = "B" & stepline
    Range(pos).Select
    ActiveCell.FormulaR1C1 = "=EXACT(RC[1],R[1]C[1])"
    Range(pos).Select
    rangetire = pos & ":B" & lastline
    If lastline > stepline Then
     Selection.AutoFill Destination:=Range(rangetire), Type:=xlFillDefault
    End If

   'positionnement sur la dernière ligne de la colonne B
    positionstart = "B" & lastline
    Range(positionstart).Select
   
GoTo jump
    'Recherche des doublons via le code Vrai dans la colonne B
    ' et si doublon addition des quantité et supression d'une ligne
   
    nrow = lastline
   Do While nrow > stepline - 1
   
    celvaleur = Cells(nrow, 2).Value
   
     
   If celvaleur = "Faux" Then
     nrow = nrow - 1
    Else
      val1 = Cells(nrow, "E").Value
      val2 = Cells(nrow + 1, "E").Value
      valsum = val1 + val2
      posit = "E" & nrow
      Range(posit).Select
      ActiveCell.FormulaR1C1 = valsum
     
      Rows(nrow + 1).Select
      Selection.Delete
      nblineefface = nblineefface + 1
      nrow = nrow - 1
    End If
Loop


    'Effacement du contenu de la colonne B
    Columns("B:B").Select
    Selection.Clear
   
    'décomposition du code en code famille et code article
   nrow = stepline
   Do While nrow < lastline - nblineefface + 1
    poscel = "C" & nrow
    Range(poscel).Select
    Selection.NumberFormat = "@"   ' format text pour la celulle
    longcell = Len(ActiveCell)
    longextrait = longcell - 4
    famille = Left(ActiveCell, longextrait)
    artid = Right(ActiveCell, 4)
    ActiveCell.FormulaR1C1 = artid
    poscel = "B" & nrow
    Range(poscel).Select
    ActiveCell.FormulaR1C1 = famille
    nrow = nrow + 1
   Loop
 
   'Mise en page
jump:
   lastline = lastline - nblineefface
 
   'déplacement de la colonne des diamètres après le descriptif
    Columns("A:A").Select
    Selection.Cut
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 1
   
   
   
    'Ajoute colonne pour calcul du volume
     Range("I" & stepline).Select                                          'ajout dans dernière colonne
    ActiveCell.FormulaR1C1 = _
        "=(LEFT(MID(RC[-6],FIND("","",RC[-6],1)+2,20),5))"
    Range("I" & stepline).Select
     If lastline > stepline Then
        Selection.AutoFill Destination:=Range("I" & stepline & ":I" & lastline), Type:=xlFillSeries
    End If
    Range("I" & stepline & ":I" & lastline).Select
    Selection.Copy
    Range("J" & stepline).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Replace What:=",", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

    Application.CutCopyMode = False
    Selection.Cut
    Range("I" & stepline).Select
    ActiveSheet.Paste
    Range("I3").Select
    ActiveCell.FormulaR1C1 = "SCH"
    Range("J" & stepline).Select
    ActiveCell.FormulaR1C1 = "=concatenate(RC[-6],(RC[-1]))"
    If lastline > stepline Then
        Selection.AutoFill Destination:=Range("J" & stepline & ":J" & lastline), Type:=xlFillSeries
    End If
    Range("K" & stepline).Select

    ActiveCell.FormulaR1C1 = _
        "=VLOOKUP(RC[-1],'[Dia-Sched.xls]Feuil1'!R2C3:R250C6,4,FALSE)"  'attention accepte 250 lignes dans dia-sched

    If lastline > stepline Then
        Selection.AutoFill Destination:=Range("K" & stepline & ":K" & lastline), Type:=xlFillSeries
    End If
    Range("L" & stepline).Select
    ActiveCell.FormulaR1C1 = "=RC[-1]*RC[-7]/1000000000"

    If lastline > stepline Then
        Selection.AutoFill Destination:=Range("L" & stepline & ":L" & lastline), Type:=xlFillSeries
    End If

    Range("L" & lastline + 1).Select
    zonesum = "=SUM(R[-" & lastline - 1 & "]C:R[-1]C)"
    ActiveCell.FormulaR1C1 = zonesum
    Columns("L:L").Select
    Selection.NumberFormat = "0.0000"
    Range("L1").Select
    With Selection
        .HorizontalAlignment = xlCenter
    End With
   
    Range("F1").Select
    Selection.Copy
    Range("G1").Select
    ActiveSheet.Paste
   

    Range("B:E,G:G,L:L").Select
    Range("L1").Activate
    Selection.Copy
    Sheets.Add.Name = "HYDRO"
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
       

           
       
    Rows("4:4").Select
    Selection.Insert Shift:=xlDown
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Ident Code"
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "Description"
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "DIA"
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "Length (mm)"
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "Weight (kg)"
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "Vol  (M³)"
   
   
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "VOLUME HYDRO"
    With ActiveCell.Characters(Start:=1, Length:=12).Font
        .Name = "Arial"
        .FontStyle = "Gras"
        .Size = 20
    End With
    Columns("A:F").EntireColumn.AutoFit
    Rows("1:2").Select
    Selection.Font.Bold = True
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
    End With

    Range("A1:F2").Select
    With Selection.Interior
        .ColorIndex = 6   'couleur jaune pour titre
        .Pattern = xlSolid
    End With
   
'   zonetr = "F" & lastline + 2
     Range("F" & lastline + 2).Select
    Selection.Font.Bold = True
     With Selection.Interior
        .ColorIndex = 43
        .Pattern = xlSolid
    End With
   
     Range("A4:F4").Select
    Selection.Font.Bold = True
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.4
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
    End With



'   Application.DisplayAlerts = False
   
'    For Each sh In ThisWorkbook.Sheets

 
  '  If InStr(sh.Name, "SP3D") = 0 And InStr(sh.Name, "HYDRO") = 0 Then
  '      Sheets(sh.Name).Select
  '      ActiveWindow.SelectedSheets.Delete
       
  '  End If
     
'      Application.DisplayAlerts = True


'   Next
 
    Sheets("Sheet1").Select
    ActiveWindow.SelectedSheets.Delete


sortie:

'   ActiveWorkbook.Close      
   
norun:

End With
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

R
  • Question
XL 2019 Lancer macro etape par etape
Réponses
5
Affichages
462
Rabeto
R
C
  • Question
XL 2016 vba , bug sur une macro lors delete xlup
Réponses
7
Affichages
322
ciocciu
C
O
  • Question
Microsoft 365 Tri filtre contextuel ne fonctionnant pas après l'enregistrement d'une Macro
Réponses
5
Affichages
170
sylvanu
sylvanu
C
  • Question
Microsoft 365 Répétition action sur plusieurs feuille d'un classeur
Réponses
4
Affichages
259
sylvanu
sylvanu
C
  • Question
Microsoft 365 Liste critère détaillé lors d'une macro
Réponses
9
Affichages
129
Chounoé
C
P
  • Question
Microsoft 365 Erreur "Type défini par l'utilisateur non défini
2 3
Réponses
33
Affichages
578
Piment
P
T
  • Question
XL 2019 Validation par étapes et par différentes personnes Formule ou Macro
5 6 7
Réponses
104
Affichages
3 K
cp4
cp4
Electron24
  • Question
Microsoft 365 Classeur disparu
2
Réponses
19
Affichages
535
VIARD
V
F
  • Question
XL 2016 AIDE RECHERCHEV automatisée sur onglets variables
Réponses
5
Affichages
153
FURUKU
F
L
  • Question
Microsoft 365 Macro choisir onglet à exporter dans un nouveau classeur
Réponses
5
Affichages
348
l.et.lilou
L

Membres actuellement en ligne

14 membres et 119 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 111
Messages
2 085 405
Membres
102 883
dernier inscrit
jameseyz