Macro independante d'une feuille et permetant d'en créer d'autres

-miss- · 27 Janvier 2011

Bonjour

Je me permet de re revenir vers vous car j'ai encore une petite demande encore.
j'ai une macro qui récupère des informations depuis d'autres fichiers excel, jusque la tout va bien.
mais ces informations sont classé selon "espace" donc à chaque fois que j'ai besoin d'un espace je suis obligée de modifier la macro et mettre quel espace dont j'ai besoin
voici la macro:

Private Function fillReviews(i, Version, folderpath, team) As Integer

Set fso = CreateObject("Scripting.FileSystemObject")
folderpath = folderpath + Version + "\"
Set objFolder = fso.GetFolder(folderpath)
Set objFileList = objFolder.Files

Dim totalEffort
Set objSheet = ActiveWorkbook.Worksheets("Feuil1")

For Each File In objFileList
j = 9
fullpath = folderpath & "\" & File.Name

Workbooks.Open filename:=folderpath + File.Name
objSheet.Cells(i, j - 3).Value = ActiveWorkbook.Sheets.Item(1).Cells(11, 7).Value
objSheet.Cells(i, j - 1).Value = Version
objSheet.Cells(i, j).Value = team
objSheet.Cells(i, j + 1).Value = File.Name
j = j + 2
objSheet.Cells(i, j + 1).Value = ActiveWorkbook.Sheets.Item(1).Cells(24, 7).Value
objSheet.Cells(i, j + 2).Value = ActiveWorkbook.Sheets.Item(1).Cells(26, 7).Value
objSheet.Cells(i, j + 3).Value = ActiveWorkbook.Sheets.Item(1).Cells(28, 7).Value

objSheet.Cells(i, j + 5).Value = ActiveWorkbook.Sheets.Item(1).Cells(24, 18).Value
' total effort
totalEffort = ActiveWorkbook.Sheets.Item(1).Cells(7, 18).Value
If totalEffort < 1 Then totalEffort = 1
objSheet.Cells(i, j + 6).Value = totalEffort
' number of page
If (ActiveWorkbook.Sheets.Item(1).Cells(20, 18).Value <= 0) Then
objSheet.Cells(i, j + 8).Value = 1

Else

objSheet.Cells(i, j + 8).Value = ActiveWorkbook.Sheets.Item(1).Cells(20, 18).Value
End If
' status
If (InStr(1, File.Name, "close") > 0 Or InStr(1, File.Name, "CLOSE") > 0) Then

objSheet.Cells(i, j + 10).Value = "CLOSED"

Else

objSheet.Cells(i, j + 10).Value = ActiveWorkbook.Sheets.Item(1).Cells(46, 7).Value

End If

ActiveWorkbook.Close

i = i + 1

Next
fillReviews = i
End Function

Sub DoReviews()

Application.ScreenUpdating = False
Dim fso, objFolder, obFileList, folderpath, fullpath, xl, i, j, valeur
Dim espace
espace = "1"
i = 2
i = fillReviews(i, espace, "C:\....", "compta")
i = fillReviews(i, espace, "C:\....", "info")
i = fillReviews(i, espace, "C:....", "tech")
Application.ScreenUpdating = True

End Sub

et voici le fichier quand il a récupéré toute les infos depuis les autres fichiers excel.

mon problème est que ma macro est dépendante de la feuille "Feuil1" et que j'aimerais bien avoir le choix quel espace afficher et qu'il s'affiche dans une autre feuille nomé "1 par exemple si l'espace est 1, 2 si espace 2 etc... "

je ne sais pas si je suis claire ...
merci d'avance
Bonne journée

KenDev · 27 Janvier 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour -miss-,

Essaye ça :

Pour le choix de l'espace emplacer

VB:

espace = "1"

par

VB:

espace = Application.InputBox(prompt:="espace ?", Default:="1")

Si espace est forcément un nombre rajouter ..., Type:=1 dans les paramètres ou 2 pour un texte.

Pour la feuille, à la suite de l'input box, ajouter

VB:

Worksheets(espace).Activate

à la condition que la feuille en question existe bien déjà. et remplacer

Dans la fonction fillReviews modifier

VB:

Set objSheet = ActiveWorkbook.Worksheets("Feuil1")

par

VB:

Set objSheet = ActiveWorkbook.Worksheets(Version)

Si la feuille espace n'existe pas forcément et que en ce cas il faut la créer ajouter le code suivant :

VB:

vSI = SheetIs(espace)
    If vSI = False Then
        Sheets.Add
        ActiveSheet.Name = espace
    Else
        Worksheets(espace).Activate
    End If

en remplacement de

VB:

Worksheets(espace).Activate

En tête de la macro rajouter

VB:

Dim vSI as boolean

Et enfin ajouter cette fonction dans le module

VB:

Function SheetIs(ShName) As Boolean
    Dim oWS As Object
    On Error Resume Next
    Set oWS = Sheets(ShName)
    If Err = 0 Then SheetIs = True
    Set oWS = Nothing
End Function

Cordialement

-miss- · 28 Janvier 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour Kendev,
Je te remercie pour la réponse, mais je ne sais pas ca ne marche pas j'ai une erreur après qu'il me pose la question de quel "espace" ? je met le numéro et puis plus rien..chemin d'acces introuvable

Private Function fillReviews(i, Version, folderpath, team) As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
folderpath = folderpath + Version + "\"
Set objFolder = fso.GetFolder(folderpath)
Set objFileList = objFolder.Files

Dim totalEffort
Set objSheet = ActiveWorkbook.Worksheets(Version)

For Each File In objFileList
j = 9
fullpath = folderpath & "\" & File.Name
Workbooks.Open filename:=folderpath + File.Name
objSheet.Cells(i, j - 3).Value = ActiveWorkbook.Sheets.Item(1).Cells(11, 7).Value
objSheet.Cells(i, j - 1).Value = Version
objSheet.Cells(i, j).Value = team
objSheet.Cells(i, j + 1).Value = File.Name
j = j + 2
objSheet.Cells(i, j + 1).Value = ActiveWorkbook.Sheets.Item(1).Cells(24, 7).Value
objSheet.Cells(i, j + 2).Value = ActiveWorkbook.Sheets.Item(1).Cells(26, 7).Value
objSheet.Cells(i, j + 3).Value = ActiveWorkbook.Sheets.Item(1).Cells(28, 7).Value

objSheet.Cells(i, j + 5).Value = ActiveWorkbook.Sheets.Item(1).Cells(24, 18).Value
' total effort
totalEffort = ActiveWorkbook.Sheets.Item(1).Cells(7, 18).Value
If totalEffort < 1 Then totalEffort = 1
objSheet.Cells(i, j + 6).Value = totalEffort
' number of page
If (ActiveWorkbook.Sheets.Item(1).Cells(20, 18).Value <= 0) Then
objSheet.Cells(i, j + 8).Value = 1

Else

objSheet.Cells(i, j + 8).Value = ActiveWorkbook.Sheets.Item(1).Cells(20, 18).Value
End If
' status
If (InStr(1, File.Name, "close") > 0 Or InStr(1, File.Name, "CLOSE") > 0) Then

objSheet.Cells(i, j + 10).Value = "CLOSED"

Else

objSheet.Cells(i, j + 10).Value = ActiveWorkbook.Sheets.Item(1).Cells(46, 7).Value

End If

ActiveWorkbook.Close

i = i + 1

Next
fillReviews = i
vSI = SheetIs(Version)
If vSI = False Then
Sheets.Add
ActiveSheet.Name = espace
Else
Worksheets(Version).Activate
End If
End Function
Function SheetIs(ShName) As Boolean
Dim oWS As Object
On Error Resume Next
Set oWS = Sheets(ShName)
If Err = 0 Then SheetIs = True
Set oWS = Nothing
End Function
Sub DoReviews()

Application.ScreenUpdating = False
Dim fso, objFolder, obFileList, folderpath, fullpath, xl, i, j, valeur
Dim Version
Dim vSI As Boolean
Version = Application.InputBox(prompt:="version ?", Default:="33", Type:=2)
i = 2
i = fillReviews(i, version, "C:\....", "compta")
i = fillReviews(i, version, "C:\....", "info")
i = fillReviews(i,version, "C:....", "tech")
Application.ScreenUpdating = True
End Sub

J'ai remplacé espace par version

-miss- · 28 Janvier 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

non finalement ça marche la macro mais le problème maintenant c'est qu'elle ne crée pas la page elle même, et que quand je crée la page il prend juste les info sans les noms des colonnes et la forme du fichiers ( couleurs et formes)
merci d'avance de ton aide

KenDev · 28 Janvier 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour Miss,

Tu as collé le bloc

VB:

vSI = SheetIs(Version)
If vSI = False Then
Sheets.Add
ActiveSheet.Name = espace
Else
Worksheets(Version).Activate
End If

à la fin de la fonction fillReviews au lieu de dans la fonction DoReviews. Je te colle le code intégral ce sera plus simple.

fonction fillreviews :

VB:

Private Function fillReviews(i, Version, folderpath, team) As Integer


Set fso = CreateObject("Scripting.FileSystemObject")
folderpath = folderpath + Version + "\"
Set objFolder = fso.GetFolder(folderpath)
Set objFileList = objFolder.Files

Dim totalEffort
Set objSheet = ActiveWorkbook.Worksheets(Version)


For Each File In objFileList
j = 9
fullpath = folderpath & "\" & File.Name



Workbooks.Open Filename:=folderpath + File.Name
objSheet.Cells(i, j - 3).Value = ActiveWorkbook.Sheets.Item(1).Cells(11, 7).Value
objSheet.Cells(i, j - 1).Value = Version
objSheet.Cells(i, j).Value = team
objSheet.Cells(i, j + 1).Value = File.Name
j = j + 2
objSheet.Cells(i, j + 1).Value = ActiveWorkbook.Sheets.Item(1).Cells(24, 7).Value
objSheet.Cells(i, j + 2).Value = ActiveWorkbook.Sheets.Item(1).Cells(26, 7).Value
objSheet.Cells(i, j + 3).Value = ActiveWorkbook.Sheets.Item(1).Cells(28, 7).Value

objSheet.Cells(i, j + 5).Value = ActiveWorkbook.Sheets.Item(1).Cells(24, 18).Value
' total effort
totalEffort = ActiveWorkbook.Sheets.Item(1).Cells(7, 18).Value
If totalEffort < 1 Then totalEffort = 1
objSheet.Cells(i, j + 6).Value = totalEffort
' number of page
If (ActiveWorkbook.Sheets.Item(1).Cells(20, 18).Value <= 0) Then
objSheet.Cells(i, j + 8).Value = 1

Else


objSheet.Cells(i, j + 8).Value = ActiveWorkbook.Sheets.Item(1).Cells(20, 18).Value
End If
' status
If (InStr(1, File.Name, "close") > 0 Or InStr(1, File.Name, "CLOSE") > 0) Then

objSheet.Cells(i, j + 10).Value = "CLOSED"

Else

objSheet.Cells(i, j + 10).Value = ActiveWorkbook.Sheets.Item(1).Cells(46, 7).Value

End If

ActiveWorkbook.Close

i = i + 1

Next
fillReviews = i
End Function

Sub DoReviews :

VB:

Sub DoReviews()

Application.ScreenUpdating = False
Dim fso, objFolder, obFileList, folderpath, fullpath, xl, i, j, valeur
Dim espace
Dim vSI As Boolean
espace = Application.InputBox(prompt:="espace ?", Default:="1")
vSI = SheetIs(espace)
If vSI = False Then
    Sheets.Add
    ActiveSheet.Name = espace
Else
    Worksheets(espace).Activate
End If
i = 2
i = fillReviews(i, espace, "C:\....", "compta")
i = fillReviews(i, espace, "C:\....", "info")
i = fillReviews(i, espace, "C:....", "tech")
Application.ScreenUpdating = True

End Sub

Fonction SheetIs:

VB:

Function SheetIs(ShName) As Boolean
    Dim oWS As Object
    On Error Resume Next
    Set oWS = Sheets(ShName)
    If Err = 0 Then SheetIs = True
    Set oWS = Nothing
End Function

Cordialement

KD

-miss- · 1 Février 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour KD,
Merci beaucoup pour ta réponse , finalement ça marche c'est cool!!
mais j'ai un autre problème :s
en fait j'ai des formules dans le fichier ci-dessous qui utilise les données récupéré par la macro , je veux que ces formule soit reprises dans la macro pour que quand il crée un nouveau sheet "espace 1 ;2 etc.." il recopie aussi ces formules ..
ps : la page data sera toujours dans le fichier...

merci encore

-miss- · 2 Février 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour
j'ai essayais de faire quelques chose de ce genre

Range("V2").Select
ActiveCell.FormulaR1C1 = "=RC[-10]/RC[-5]"
Range("V2").Select
Selection.AutoFill Destination:=Range("V2:V65"), Type:=xlFillDefault
Range("V2:V65").Select
Range("W2").Select
ActiveCell.FormulaR1C1 = "=RC[-10]/RC[-6]"
Range("W2").Select
Selection.AutoFill Destination:=Range("W2:W65"), Type:=xlFillDefault
Range("W2:W65").Select
Range("X2").Select
ActiveCell.FormulaR1C1 = "=RC[-12]/RC[-5]"
Range("X2").Select
Selection.AutoFill Destination:=Range("X2:X65"), Type:=xlFillDefault
Range("X2:X65").Select

ça marche mais c'est très compliqué je pense qu'il y a plus simple , je l'ai fais en faisant une nouvelle macro

merci de votre aide j'en ai besoin 🙁

KenDev · 2 Février 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour Miss,

Dans ton classeur il n'y a qu'un tableau avec des colonnes de 1 à 7 et une sub Sub Worksheet_SelectionChange placée dans un module standard. Difficille d'imaginer ce que tu veux faire. ;-) Voilà déjà une traduction du code précédent en tant que macro lancée indépendament.

VB:

Sub testff()
    Dim oWS As Worksheet
    Dim TabLastRow As Long
    '----------------code------------------------
    Set oWS = Worksheets("La feuille des calculs à faire")  '-> à adapter
     '-------------code-------------------------
        TabLastRow = oWS.Cells(Rows.Count, 1).End(xlUp).Row '-> à adapter (remplacer 1 par le n° d'une colonne du tableau sans cellules vide)
        Range(oWS.Cells(2, 22), oWS.Cells(TabLastRow, 22)) = "=RC[-10]/RC[-5]"
        Range(oWS.Cells(2, 23), oWS.Cells(TabLastRow, 23)) = "=RC[-10]/RC[-6]"
        Range(oWS.Cells(2, 24), oWS.Cells(TabLastRow, 24)) = "=RC[-12]/RC[-5]"
        Range(oWS.Cells(2, 22), oWS.Cells(TabLastRow, 24)).Copy 'ces 3 dernières ligne si tu souhaites remplacer les formules par leur valeur
        Range(oWS.Cells(2, 22), oWS.Cells(TabLastRow, 24)).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
'---------------------------code-------------------------------
    Set oWS = Nothing
End Sub

Si tu souhaites l'inclure dans une macro existante: Mettons que tu viennes de créer la feuille représentée par la variable 'espace' (c'est à dire qu'il y a déjà quelque part un 'set espace = activesheet' ou dans le genre:

VB:

Dim TabLastRow As Long
    '------------------code----------------------
    TabLastRow = espace.Cells(Rows.Count, 1).End(xlUp).Row '-> à adapter (remplacer 1 par le n° d'une colonne du tableau sans cellules vide)
    Range(espace.Cells(2, 22), espace.Cells(TabLastRow, 22)) = "=RC[-10]/RC[-5]"
    Range(espace.Cells(2, 23), espace.Cells(TabLastRow, 23)) = "=RC[-10]/RC[-6]"
    Range(espace.Cells(2, 24), espace.Cells(TabLastRow, 24)) = "=RC[-12]/RC[-5]"
    Range(espace.Cells(2, 22), espace.Cells(TabLastRow, 24)).Copy 'ces 3 dernières ligne si tu souhaites remplacer les formules par leur valeur
    Range(espace.Cells(2, 22), espace.Cells(TabLastRow, 24)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

Cordialement

KD

-miss- · 3 Février 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour KD
Merci pour ta réponse mais je n'arrive pas à l'exploiter je sais pas pourquoi
je pense que je n'étais pas trop claire .. 🙁
donc le fichier rangement récupère des données à l'aide de la macro que je t'avais montré au début ( DoReviews() ... etc)
après avoir récupéré les données, j'ai besoin que dans le même sheet " espace" il calcul des ratios 1,2 et 3 ( dans le vrai fichier c'est les colonnes v, w, x )
, je veux que cette fonction soit dans la macro prétendante, j'ai réussi à la faire marcher avec

Range("V2").Select
ActiveCell.FormulaR1C1 = "=RC[-10]/RC[-5]"
Range("V2").Select
Selection.AutoFill Destination:=Range("V2:V65"), Type:=xlFillDefault
Range("V2:V65").Select
Range("W2").Select
ActiveCell.FormulaR1C1 = "=RC[-10]/RC[-6]"
Range("W2").Select
Selection.AutoFill Destination:=Range("W2:W65"), Type:=xlFillDefault
Range("W2:W65").Select
Range("X2").Select
ActiveCell.FormulaR1C1 = "=RC[-12]/RC[-5]"
Range("X2").Select
Selection.AutoFill Destination:=Range("X2:X65"), Type:=xlFillDefault
Range("X2:X65").Select

mais c'est pas très propre car il calcule de la ligne 2 a la ligne 65.. j'ai besoin que le calcul soit effectué tant que les lignes sont pas vides ( tant qu'il y a les données )
le fichier que j'ai uploadé c'est le template du fichier remplie déjà ...
j'espere être clair cette fois ci
merciii encoree!!

KenDev à dit:

Bonjour Miss,

Dans ton classeur il n'y a qu'un tableau avec des colonnes de 1 à 7 et une sub Sub Worksheet_SelectionChange placée dans un module standard. Difficille d'imaginer ce que tu veux faire. ;-) Voilà déjà une traduction du code précédent en tant que macro lancée indépendament.

VB:

Sub testff()
    Dim oWS As Worksheet
    Dim TabLastRow As Long
    '----------------code------------------------
    Set oWS = Worksheets("La feuille des calculs à faire")  '-> à adapter
     '-------------code-------------------------
        TabLastRow = oWS.Cells(Rows.Count, 1).End(xlUp).Row '-> à adapter (remplacer 1 par le n° d'une colonne du tableau sans cellules vide)
        Range(oWS.Cells(2, 22), oWS.Cells(TabLastRow, 22)) = "=RC[-10]/RC[-5]"
        Range(oWS.Cells(2, 23), oWS.Cells(TabLastRow, 23)) = "=RC[-10]/RC[-6]"
        Range(oWS.Cells(2, 24), oWS.Cells(TabLastRow, 24)) = "=RC[-12]/RC[-5]"
        Range(oWS.Cells(2, 22), oWS.Cells(TabLastRow, 24)).Copy 'ces 3 dernières ligne si tu souhaites remplacer les formules par leur valeur
        Range(oWS.Cells(2, 22), oWS.Cells(TabLastRow, 24)).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
'---------------------------code-------------------------------
    Set oWS = Nothing
End Sub

Si tu souhaites l'inclure dans une macro existante: Mettons que tu viennes de créer la feuille représentée par la variable 'espace' (c'est à dire qu'il y a déjà quelque part un 'set espace = activesheet' ou dans le genre:

VB:

Dim TabLastRow As Long
    '------------------code----------------------
    TabLastRow = espace.Cells(Rows.Count, 1).End(xlUp).Row '-> à adapter (remplacer 1 par le n° d'une colonne du tableau sans cellules vide)
    Range(espace.Cells(2, 22), espace.Cells(TabLastRow, 22)) = "=RC[-10]/RC[-5]"
    Range(espace.Cells(2, 23), espace.Cells(TabLastRow, 23)) = "=RC[-10]/RC[-6]"
    Range(espace.Cells(2, 24), espace.Cells(TabLastRow, 24)) = "=RC[-12]/RC[-5]"
    Range(espace.Cells(2, 22), espace.Cells(TabLastRow, 24)).Copy 'ces 3 dernières ligne si tu souhaites remplacer les formules par leur valeur
    Range(espace.Cells(2, 22), espace.Cells(TabLastRow, 24)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

Cordialement

KD

KenDev · 3 Février 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour Miss, le fil,

A priori, le seul truc que tu as faire en utilisant le code fourni, c'est de remplacer espace par la variable représentant la feuille dans le code original.

Cordialement

KD

-miss- · 4 Février 2011

Re : Macro independante d'une feuille et permetant d'en créer d'autres

Bonjour,
Merci KD vraiment je pense que c'est bon 🙂 !!!

Macro independante d'une feuille et permetant d'en créer d'autres

-miss-

XLDnaute Junior

Pièces jointes

KenDev

XLDnaute Impliqué

-miss-

XLDnaute Junior

-miss-

XLDnaute Junior

KenDev

XLDnaute Impliqué

-miss-

XLDnaute Junior

Pièces jointes

-miss-

XLDnaute Junior

KenDev

XLDnaute Impliqué

-miss-

XLDnaute Junior

KenDev

XLDnaute Impliqué

-miss-

XLDnaute Junior

Discussions similaires

Macro independante d'une feuille et permetant d'en créer d'autres

XLDnaute Junior

Pièces jointes

XLDnaute Impliqué

XLDnaute Junior

XLDnaute Junior

XLDnaute Impliqué

XLDnaute Junior

Pièces jointes

XLDnaute Junior

XLDnaute Impliqué

XLDnaute Junior

XLDnaute Impliqué

XLDnaute Junior

Discussions similaires

Privacy & Transparency

Privacy & Transparency