Le Kiosque à Ingénieurs

Pipo, flan et yaourtines.
 
AccueilAccueil  PortailPortail  S'enregistrerS'enregistrer  Connexion  

Partagez | 
 

 Boucles propres en vba ou toutes autres choses

Voir le sujet précédent Voir le sujet suivant Aller en bas 
AuteurMessage
LE56ENFORCE

avatar

Localisation : En avant Guingamp!
Messages : 505
Age : 15

MessageSujet: Boucles propres en vba ou toutes autres choses   Ven 26 Juin - 9:12

Bref et propre

Dim b As Long
Dim c() As Long

If mouleNb <> "0" Then
For Each a In ActiveWorkbook.Sheets
c(0) = 6
i = 0
With Sheets(a.Name)
b = 6
Do
i = i + 1
Set C1 = .Columns(Cool.Find(What:=mouleNb, After:=.Cells(b ,Cool, SearchDirection:=wlNext)
If Not C1 Is Nothing Then
R1 = C1.Row
b = C1.Row
For i = 1 To 7
Sheet33.Cells(Ct,i).Value = .Cells(R1, i).Value
Next
Ct = Ct + 1
Else
Exit Do
End If
c(i) = b
Loop While c(i) > c (i-1)
End With
Next a
Revenir en haut Aller en bas
http://livre.fnac.com/a1981015/Benedicte-Guettier-Le-mystere-de-
Loïc

avatar

Localisation : ♜♜♜
Messages : 1408
Age : 24

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Ven 26 Juin - 18:36

C'est toujours marrant d'appeler ses variables "a", "b", etc...
Mais après bonjour pour s'y retrouver.
Revenir en haut Aller en bas
http://kaidouai.forumactif.com
Pierre

avatar

Localisation : St Pichon-les-mangoustes
Messages : 958

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Sam 27 Juin - 1:14

J'utilise la méthode Bouraqadi : mes noms de variables font minimum 30 caractères.

public Integer alorsLaCEstUnNombreQuiVousVoyezVaServirACalculerLeRatioDePatates = 3;
Revenir en haut Aller en bas
Loïc

avatar

Localisation : ♜♜♜
Messages : 1408
Age : 24

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Sam 27 Juin - 9:27

Perso dans les programmes que je fais ici, je mets les noms de variables en français.
Ce sera une surprise pour les prochains stagiaires Smile
Revenir en haut Aller en bas
http://kaidouai.forumactif.com
LE56ENFORCE

avatar

Localisation : En avant Guingamp!
Messages : 505
Age : 15

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Mar 30 Juin - 16:45

Création d'un fichier excel "macro enabled":

'Create folder properly
Dim BG As Long

Private Sub Userform_initialize()
   'Initializtion of the Userform
   FAE_b.Value = False
   FIS_b.Value = False
   PlantC.Clear
   BG = 0
End Sub
Private Sub FAE_b_Click()
   FIS_b.Value = False
   PlantC.Clear
   With PlantC
       For i = 10 To 45
           .AddItem Sheet11.Cells(i, 10).Value
       Next i
   End With
   BG = 2
End Sub
Private Sub FIS_b_Click()
   FAE_b.Value = False
   PlantC.Clear
   With PlantC
       For i = 10 To 83
           .AddItem Sheet11.Cells(i, 3).Value
       Next i
   End With
   BG = 1
End Sub
Private Sub Cancel_1_Click()
   'Close the Userform
   Unload Me
End Sub

Private Sub CommandButton1_Click()
   Dim rawFileName As String
   Dim Plant As String
   Dim IMMNum As Long
   Plant = PlantC.Value
   IMMNum = IMM_number.Value
   rawFileName = BuildIMMName(Plant, IMM_number)
   If rawFileName <> "" Then
       'Add the IMM number to the IMM dimensions sheet
       Sheet3.Unprotect "bouse"
           With Sheet3
               .Cells(7, 2).Value = PlantC.Value
               .Cells(10, 2).Value = rawFileName
           End With
       Sheet3.Protect "bouse"
       'Achieved the IMM RFQ
       If CreateCompletePath("D:\IMM", "D:\IMM\RFQ") Then
           If SaveNewRFQ("D:\IMM\RFQ", rawFileName) Then
               'Activate the IMM dimensions sheet
               Unload Me
               Sheet3.Activate
               az = MsgBox("Design your IMM!", , "Injection moulding machine RFQ")
               a0 = MsgBox("Determine your IMM dimensions!", , "Injection moulding machine RFQ")
           End If
       End If
   End If
End Sub

Function SaveNewRFQ(ByVal glpath As String, Optional ByVal fileN As String) As Boolean
   'Clean the file name and save
   SaveNewRFQ = False
   fileNameCleaned = CleanFileName(fileN)
   fileNameCleaned = glpath & "\" & fileNameCleaned
   On Error GoTo err
   ThisWorkbook.SaveAs fileName:=fileNameCleaned, FileFormat:=52, ConflictResolution:=xlUserResolution, AddToMru:=True
   SaveNewRFQ = True
   Exit Function
err:
   e001 = MsgBox("Folders created, but no success for file saving", , "Injection moulding machine RFQ")
   SaveRFQ = False
   Exit Function
End Function

Function CreateCompletePath(ByVal path1 As String, Optional ByVal path2 As String) As Boolean
'Create the complete path to save the IMM RFQ
   Dim fso1 As New FileSystemObject
   Dim fso2 As New FileSystemObject
   Dim fld1 As Folder
   Dim fld2 As Folder
   CreateCompletePath = False
   If fso1.FolderExists(path1) Then
       If fso2.FolderExists(path2) Then
           CreateCompletePath = True
           Exit Function
       Else
           MkDir path2
           CreateCompletePath = True
           Exit Function
       End If
   Else
       MkDir path1
       MkDir path2
       CreateCompletePath = True
       Exit Function
   End If
End Function

Function CleanFileName(ByVal fileName As String) As String
'Prevent the file future file of format issues
   CleanFileName = Replace(fileName, "-", "_")
   CleanFileName = Replace(CleanFileName, "/", "_")
   CleanFileName = Replace(CleanFileName, "+", "")
   CleanFileName = Replace(CleanFileName, " ", "_")
   CleanFileName = Replace(CleanFileName, ">", "")
   CleanFileName = Replace(CleanFileName, "<", "")
   CleanFileName = Replace(CleanFileName, "?", "")
   CleanFileName = Replace(CleanFileName, "!", "")
   CleanFileName = Replace(CleanFileName, ".", "")
   CleanFileName = Replace(CleanFileName, ",", "")
   CleanFileName = Replace(CleanFileName, ";", "")
   Exit Function
End Function

Function BuildIMMName(ByVal PltName As String, Optional ByVal Number As Long) As String
   'Build the project IMM name
   Dim result As String
   BuildIMMName = ""
   result = ReasearchPlantSymb(PltName)
   If Not result = "" Then
       Number = Number + 1
       BuildIMMName = "FAU-" & result & "-IMM RFQ-" & Number
       Exit Function
   Else
       e002 = MsgBox("Impossible to find the plant symbols!", , "Injection moulding machine RFQ")
       Exit Function
   End If
End Function

Function ReasearchPlantSymb(ByVal PltNameR As String) As String
   'Search the IMM Symbol
   ReasearchPlantSymb = ""
   If BG = 1 Then
       'Research in FIS list
       With Sheet11
           Set C1 = .Columns(3).Find(What:=PltNameR, After:=.Cells(10, 3), SearchDirection:=wlNext)
           If Not C1 Is Nothing Then
               R1 = C1.Row
               ReasearchPlantSymb = .Cells(R1, 5).Value
               Exit Function
           Else
               Exit Function
           End If
       End With
   ElseIf BG = 2 Then
       'Research in FAE list
       With Sheet11
           Set C2 = .Columns(10).Find(What:=PltNameR, After:=.Cells(10, 10), SearchDirection:=wlNext)
           If Not C2 Is Nothing Then
               R2 = C2.Row
               ReasearchPlantSymb = .Cells(R2, 5).Value
               Exit Function
           Else
               Exit Function
           End If
       End With
   Else
       Exit Function
   End If
End Function
Revenir en haut Aller en bas
http://livre.fnac.com/a1981015/Benedicte-Guettier-Le-mystere-de-
Pierre

avatar

Localisation : St Pichon-les-mangoustes
Messages : 958

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Mer 17 Fév - 18:25

Ma première macro !!!§

Code:
Sub ExtractARangeOfPages()
    ' ---------- SELECT ----------
        ' Define a range of pages
        Dim rangeOfPages As Range
        ' Go to the beginning of the range
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=2
        ' Start the selection here
        Set rangeOfPages = Selection.Range
        ' Go to the end of the range
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=4
        ' Stop the selection here
        rangeOfPages.End = Selection.Bookmarks("\Page").Range.End
    
    ' ---------- COPY ----------
        ' Copy the range
        rangeOfPages.Copy

    ' ---------- PASTE ----------
        ' Open a new document
        Documents.Add
        ' Paste the extracted pages
        Selection.Paste
        ' Remove the endpagebreak, if any
        Selection.TypeBackspace
    
    ' ---------- SAVE ----------
        ' Choose the directory for the output extracted file
        ChangeFileOpenDirectory "C:\Users\A601606\Documents\KPN"
        ' Save the extracted pages as a new document
        ActiveDocument.SaveAs FileName:="extract_" & ActiveDocument.Name & ".docx"
End Sub

Ça sert à extraire une série de pages d'un document word Very Happy
Revenir en haut Aller en bas
Loïc

avatar

Localisation : ♜♜♜
Messages : 1408
Age : 24

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Mer 17 Fév - 20:43

C'est un beau bébé dis donc !

Je ne saurais pas dire pourquoi mais ça m'a l'air plus clair que le code de Paul Neutral
Revenir en haut Aller en bas
http://kaidouai.forumactif.com
Joris

avatar

Localisation : Bretagne :(
Messages : 575
Age : 24

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Jeu 18 Fév - 14:59

Loïc a écrit:

Je ne saurais pas dire pourquoi mais ça m'a l'air plus clair que le code de Paul Neutral
Peut-être parce qu'il y a un commentaire à chaque ligne de code ?

_________________
Revenir en haut Aller en bas
Loïc

avatar

Localisation : ♜♜♜
Messages : 1408
Age : 24

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Jeu 18 Fév - 16:35

Joris a écrit:
Loïc a écrit:
Je ne saurais pas dire pourquoi mais ça m'a l'air plus clair que le code de Paul Neutral
Peut-être parce qu'il y a un commentaire à chaque ligne de code ?

Pourtant Paul est plus enclin à faire des commentaires silent
Revenir en haut Aller en bas
http://kaidouai.forumactif.com
Pierre

avatar

Localisation : St Pichon-les-mangoustes
Messages : 958

MessageSujet: Re: Boucles propres en vba ou toutes autres choses   Mer 16 Mar - 11:28

Ma deuxième macro !!!  Very Happy
Code:
Option Base 0 ' First index of arrays will be 0

Sub ParagraphExportation()
   ' ---------- Identify input and output documents ----------
   Dim inputDocument As Document
   Dim outputDocument As Document
   Set inputDocument = ActiveDocument
   Set outputDocument = Documents.Add()
  
   ' ---------- Go into original document ----------
   inputDocument.Activate

   ' ---------- Define an array of titles (whose paragraphs will be exported) ----------
   Dim titlesArray(2) As String ' Highest index of array
  
   ' ---------- Fill the array (of the paragraphs that will be exported) ----------
   titlesArray(0) = "Titre 1 patate"
   titlesArray(1) = "Titre 1.1 patate douce"
   titlesArray(2) = "Titre 2.2 pomme de rainette"
  
   ' ---------- Define the array of the exported paragraphs ----------
   Dim exportedArray() As Integer ' Dynamic array for exportation
   Dim exportedArraySize As Integer ' Size of dynamic array
   exportedArraySize = -1
   Dim paragraph As String ' Candidate for exportation
  
   ' ---------- Enumerate each paragraph of the document ----------
   Dim j As Integer
   Dim amountOfParagraphs As Integer
   amountOfParagraphs = inputDocument.Paragraphs.Count
   Dim shouldWeExportThisParagraph As Boolean
   shouldWeExportThisParagraph = False
   Dim currentParagraphLevel As Integer
   currentParagraphLevel = 10
   Dim lastExportedTitleLevel As Integer
   lastExportedTitleLevel = 10
   Dim IsTitleAsBigAsPreviousTitleToExport As Boolean
   For j = 1 To amountOfParagraphs
       paragraph = inputDocument.Paragraphs(j).range.Text
      
       ' ---------- Should we export this paragraph? ----------
       currentParagraphLevel = CalculateParagraphLevel(inputDocument.Paragraphs(j).Style)
       IsTitleAsBigAsPreviousTitleToExport = currentParagraphLevel <= lastExportedTitleLevel
       If IsTitleAsBigAsPreviousTitleToExport Then ' To reset, we wait for a new title as big as the previous from the array
           ' A consequence of this is that we also export all the sub-paragraphs contained in the big title
           If IsInArray(paragraph, titlesArray) Then
               shouldWeExportThisParagraph = True ' This title is in the array, so we should export this paragraph
               lastExportedTitleLevel = currentParagraphLevel
           Else
               shouldWeExportThisParagraph = False ' This title isn't in the array, so we shouldn't export this paragraph
               lastExportedTitleLevel = 10
           End If
       End If
      
       ' ---------- Memorize paragraphs to be exported ----------
       If shouldWeExportThisParagraph Then
           ' ---------- Update array size ----------
           exportedArraySize = exportedArraySize + 1
           ReDim Preserve exportedArray(exportedArraySize)
          
           ' ---------- Add this paragraph to the exportation array ----------
           exportedArray(exportedArraySize) = j
       End If
   Next j
  
   ' ---------- If no paragraph was memorized, quit macro ----------
   If exportedArraySize < 0 Then
       MsgBox "No paragraph was selected for exportation!"
       Exit Sub
   End If
  
  
   ' ---------- Export stocked paragraphs in a new document ----------
   Dim i As Integer
   For i = 0 To exportedArraySize
       ' ---------- Go into original document ----------
       inputDocument.Activate
      
       ' ---------- Copy paragraph from original document ----------
       j = exportedArray(i)
       inputDocument.Paragraphs(j).range.Select
       Selection.Copy
      
       ' ---------- Go into exported document ----------
       outputDocument.Activate
      
       ' ---------- Paste paragraph in exported document ----------
       Selection.EndKey wdStory, wdMove
       Selection.Paste
   Next i
   ' ---------- Save exported document ----------
   ChangeFileOpenDirectory "C:\Users\A601606\Documents\KPN"
   outputDocument.SaveAs FileName:="extract_" & inputDocument.Name & ".docx"
  
   ' ---------- Display ending message ----------
   MsgBox "Exportation of paragraphs is finished."
End Sub

' ---------- Function to verify if a String is in an Array ----------
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
   Dim positionOfString As Integer
   For k = 0 To UBound(arr)
       positionOfString = InStr(stringToBeFound, arr(k))
       If positionOfString > 0 Then
           ' String was found
           IsInArray = True
           Exit Function
       End If
   Next k
  
   ' String was not found
   IsInArray = False
   Exit Function
End Function

' ---------- Function to calculate the level of a title ----------
Function CalculateParagraphLevel(paragraphStyle As Style) As Integer
   If paragraphStyle = "Titre 1" Then
       ' Big title (level 1)
       CalculateParagraphLevel = 1
       Exit Function
   Else
       If paragraphStyle = "Titre 2" Then
           ' Medium title (level 2)
           CalculateParagraphLevel = 2
           Exit Function
       Else
           If paragraphStyle = "Titre 3" Then
               ' Small title (level 3)
               CalculateParagraphLevel = 3
               Exit Function
           Else
               If paragraphStyle = "Titre 4" Then
                   ' Level 4
                   CalculateParagraphLevel = 4
                   Exit Function
               Else
                   If paragraphStyle = "Titre 5" Then
                       ' Level 5
                       CalculateParagraphLevel = 5
                       Exit Function
                   End If
               End If
           End If
       End If
   End If

   ' Default value: microscopic title
   CalculateParagraphLevel = 10
   Exit Function
End Function

Cette fois-ci, c'est pour extraire des paragraphes d'un document à partir de leurs titres.

Dans cet exemple, à partir de ce document :
Citation :
Mon document passionnant
Titre 1 patate
Lalala
Titre 1.1 patate douce
Lululu
Titre 1.2 patate sautée
Lololo
Titre 2 pomme
lélélé
Titre 2.1 pomme d’api
Lilili
Titre 2.2 pomme de rainette
Lylyly
...on extrait :
Citation :
Titre 1 patate
Lalala
Titre 1.1 patate douce
Lululu
Titre 1.2 patate sautée
Lololo
Titre 2.2 pomme de rainette
Lylyly
Parce que j'ai listé les titres suivants :
Code:
titlesArray(0) = "Titre 1 patate"
titlesArray(1) = "Titre 1.1 patate douce"
titlesArray(2) = "Titre 2.2 pomme de rainette"
Revenir en haut Aller en bas
Contenu sponsorisé




MessageSujet: Re: Boucles propres en vba ou toutes autres choses   

Revenir en haut Aller en bas
 
Boucles propres en vba ou toutes autres choses
Voir le sujet précédent Voir le sujet suivant Revenir en haut 
Page 1 sur 1
 Sujets similaires
-
» Liens, bébés et autres choses... AIDEZ LES A VIVRE !!
» [Terminé] Là où un vol peut cacher bien d'autres choses ... (PV Bardok)
» Besoin d'une révision ou d'autres choses ? [PV: Tylan Mcleod]
» Toutes ces choses qu'on ne s'est pas dites ♥ LILY JOLIE
» Toutes ces choses que nous ne nous sommes pas dites ∞ Arthur Paton

Permission de ce forum:Vous ne pouvez pas répondre aux sujets dans ce forum
Le Kiosque à Ingénieurs :: Public :: Mécanique générale-
Sauter vers: