Exécuter ma macro sur une feuille défini

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion Ibrahimi
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
I

Ibrahimi

Guest
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
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

D
  • Résolu(e)
XL 2019 Boucle sur plusieurs feuilles
Réponses
6
Affichages
577
dadaze
D
M
  • Question Question
XL 2016 pb création de tableau par macro
Réponses
10
Affichages
370
ChTi160
ChTi160
F
  • Question Question
XL 2016 recherche données et collage
Réponses
4
Affichages
112
finarobert
F
litelsousa
  • Question Question
Microsoft 365 Graphique avec valeur sur différentes feuilles
Réponses
3
Affichages
162
sousou
sousou
A
  • Question Question
Autres Excel 2007 Recherche dans plusieurs feuilles INDEX EQUIV INDIRECT DECALER
Réponses
3
Affichages
180
AD74
A
P
  • Résolu(e)
XL 2021 Comment détecter la modification MANUELLE d'une cellule dans une feuille ?
Réponses
3
Affichages
241
PRy
P
M
  • Résolu(e)
XL 2021 Problème d'activation d'une macro pour transférer des valeurs d'une feuille 1 à une feuille 2
Réponses
3
Affichages
339
MATLEA
M
P
  • Résolu(e)
Microsoft 365 Utiliser la même macro dans des feuilles différentes
2 3
Réponses
35
Affichages
1 K
cathodique
cathodique
N
  • Résolu(e)
Microsoft 365 Macro enregistrement automatique pdf
2
Réponses
18
Affichages
885
Nounours4173
N
G
  • Question Question
Microsoft 365 Tri su nom et somme
Réponses
5
Affichages
247
GUERET
G
S
  • Question Question
XL 2016 Conserver la police et couleur
Réponses
4
Affichages
140
SVI
S
KTM
  • Question Question
XL 2016 Dupliquer et renommer feuille
Réponses
4
Affichages
134
KTM
KTM
B
  • Résolu(e)
XL 2019 Sur une feuille protégée effacer les cellules déverrouillées par macro
Réponses
6
Affichages
153
Nain porte quoi
N
E
  • Résolu(e)
Microsoft 365 Séparer une feuille Excel en deux partie complètement indépendantes ?
2
Réponses
20
Affichages
574
Elnono51
E
OlivGM
  • Question Question
XL 2013 Annulé
Réponses
6
Affichages
274
bsalv
B
D
  • Question Question
XL 2021 Problème de macro
Réponses
5
Affichages
201
Didierpasdoué
D
B
  • Résolu(e)
XL 2019 Macro pour copier des cellules d'une feuille de barèmes
Réponses
6
Affichages
218
berru76
B
D
  • Question Question
Microsoft 365 Filtrer sur la feuille 1 et que ce même filtre s'applique sur le feuil 2
Réponses
5
Affichages
316
desmonts
D
P
  • Question Question
XL 2021 Macro de découpage suivant une clé
Réponses
14
Affichages
400
job75
job75
Phil Du59
  • Résolu(e)
Microsoft 365 Macro de tri
Réponses
2
Affichages
176
Phil Du59
Phil Du59
Retour