Se connecter / S'enregistrer
Votre question
Résolu

VBA Importer m onglets de n classeurs dans une nouvelle feuille

Tags :
  • Programmation
Dernière réponse : dans Programmation
24 Août 2016 23:24:01

Bonsoir,
J'ai besoin de votre aide pour réaliser une macro capable de:
1-Importer tous les onglets visibles de plusieurs classeurs provenant d'un même dossier pour simplifier :)  ( sinon éventuellement si possible une boite de dialogue me demandant de sélectionner les classeurs dans différents fichiers)
2-Les onglets et le nombre de lignes sont variables d'un classeur à l'autre, les onglets ont des entêtes identiques mais ne commencent pas forcement à la même ligne (l'idée est de commencer l'importation après l'entête de colonne "affaires" et à partir de "en cours", et de copier les contenus de tous les onglets les uns en dessous des autres après avoir précisé la direction de production).
'Si possible une boite de dialogue qui simplifierait ça (je ne sais pas comment).
3-Supprimer ensuite les lignes vide pour avoir un fichier bien propre, et surtout ne rien modifier aux classeurs sources (aucune demande d'enregistrement ou de messages inutiles).

J'ai un code qui marche bien pour des classeurs simples avec une seule feuille (même configuration sur chaque feuille et les données empilées les unes en dessous des autres sans espace), j'aimerais que vous m'aidiez à l'adapter svp.
Je voudrai mettre en pièce jointe un fichier exemple, mais je ne trouve pas cette option.

  1. Sub Transferer()
  2. Dim dossier As Object, Fichier As Object
  3. Dim Chemin As String
  4. Dim Derlg As Integer
  5. Dim c As Range
  6.  
  7. Application.ScreenUpdating = False
  8. Application.DisplayAlerts = True
  9.  
  10. Derlg = Range("A65536").End(xlUp).Row + 1
  11. Range("A2:N" & Derlg).Clear
  12.  
  13. Chemin = ThisWorkbook.Path
  14. FName = Dir(Chemin & "\" & "*.xls")
  15. Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
  16.  
  17. For Each Fichier In dossier.Files
  18.  
  19. NomFichier = Fichier.Name
  20. If Not Fichier.Name = "Recap.xls" Then
  21.  
  22. Derlg = Range("A65536").End(xlUp).Row + 1
  23.  
  24. Workbooks.Open Filename:=Chemin & "/" & NomFichier
  25.  
  26. On Error Resume Next
  27.  
  28. With Workbooks(NomFichier)
  29. .Sheets("Feuil1").Range("A2:N" & Range("A65536").End(xlUp).Row).Copy ThisWorkbook.Sheets("Feuil1").Range("A" & Derlg)
  30. .Close
  31. End With
  32.  
  33. End If
  34. Next
  35.  
  36. End Sub


Merci d'avance pour votre aide :) 

Autres pages sur : vba importer onglets classeurs nouvelle feuille

a b L Programmation
25 Août 2016 07:18:59

Salut, ben c'est un excellent début ;) 
As-tu fais toi même ce code ?

On ne joint pas de fichier ici pour des raisons de sécurité, par contre les captures d'écran sont les bienvenues.
Si j'ai bien compris il te manque:
- La boucle pour chaque onglet (ici tu ne fais que la feuille1).
- La détermination de début de la plage à copier. (tu entends quoi par "direction de production" ?), le critère de début de èplage c'est quoi (ici tu parles de "affaires" et de "en cours", mais c'est pas claire pour moi, donne un exemple avec une capture d'écran)
- éliminer les lignes vides

Quelle est ton problème pour réaliser ces 3 éléments ?
Le 1 se fait avec une simple boucle "for each"
le 2 peux être réaliser de différentes façon, mais j'ai besoin de plus de précision pour choisir la meilleure voix
le 3 est encore une simple boucle (un gros piège à éviter toutefois)
m
0
l
25 Août 2016 08:24:53

drul a dit :
Salut, ben c'est un excellent début ;) 
As-tu fais toi même ce code ?

On ne joint pas de fichier ici pour des raisons de sécurité, par contre les captures d'écran sont les bienvenues.
Si j'ai bien compris il te manque:
- La boucle pour chaque onglet (ici tu ne fais que la feuille1).
- La détermination de début de la plage à copier. (tu entends quoi par "direction de production" ?), le critère de début de èplage c'est quoi (ici tu parles de "affaires" et de "en cours", mais c'est pas claire pour moi, donne un exemple avec une capture d'écran)
- éliminer les lignes vides

Quelle est ton problème pour réaliser ces 3 éléments ?
Le 1 se fait avec une simple boucle "for each"
le 2 peux être réaliser de différentes façon, mais j'ai besoin de plus de précision pour choisir la meilleure voix
le 3 est encore une simple boucle (un gros piège à éviter toutefois)

Merci, il me manque bien les 3 points que tu cites.
Je debute en vba, j'ai trouvé ce code sur internet et l'ai juste un peu modifié. Mais je n'arrive pas à ajouter une boucle et à faire fonctionner le code.
Voici l'image du fichier source (tu peux y voir la "direction de production", "affaire" et "en cours"
http://
celle du fichier de synthèse (c'est pas complet, mais l'idée est de faire quelque chose qui ressemble à ça, avec dans la colonne A le nom de la direction de production):
http://
Bonne journée



m
0
l
Contenus similaires
a b L Programmation
25 Août 2016 09:34:37

Pour mettre une image, il faut l'uploader sur un site de partage genre casimage, Tom's ne fait pas hébérgeur d'image ... et je n'ai pas accès à ton C:\ ...
m
0
l
25 Août 2016 21:37:53

Merci de votre réponse.
Je vous met les liens de deux fichiers sources et le fichier de synthèse.

Edit modération: pas de lien vers des fichiers potentiellement dangeraux pour les aidants ici. C'est interdit par le réglement du forum

Merci encore pour vos réponses.
m
0
l
a b L Programmation
26 Août 2016 07:25:40

Salut, pas de fichier ici, c'est pourquoi je te demande des captures d'écran pour bien visualiser ton problème.

pour boucler sur toutes les feuilles de chaque workbook, on peut modifier ton code de la manière suivante:
  1. Sub Transferer()
  2. Dim dossier As Object, Fichier As Object
  3. Dim wb As Workbook
  4. Dim feuille As Worksheet
  5. Dim FeuilleDest As Worksheet
  6. Dim Chemin As String
  7. Dim Derlg As Integer
  8. Dim c As Range
  9.  
  10. Application.ScreenUpdating = False
  11. Application.DisplayAlerts = True
  12.  
  13. Set FeuilleDest = ActiveSheet
  14.  
  15. Derlg = Range("A65536").End(xlUp).Row + 1
  16. Range("A2:N" & Derlg).Clear
  17.  
  18. Chemin = ThisWorkbook.Path
  19. FName = Dir(Chemin & "\" & "*.xls")
  20. Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
  21.  
  22. For Each Fichier In dossier.Files
  23.  
  24. NomFichier = Fichier.Name
  25.  
  26. If InStr(1, Fichier.Name, "Recap.xls") = 0 Then
  27.  
  28. Set wb = Workbooks.Open(Chemin & "/" & NomFichier)
  29.  
  30. For Each feuille In wb.Sheets
  31.  
  32. Derlg = FeuilleDest.Range("A65536").End(xlUp).Row + 1
  33.  
  34. On Error Resume Next
  35.  
  36. feuille.Range("A2:N" & feuille.Range("A65536").End(xlUp).Row).Copy FeuilleDest.Range("A" & Derlg)
  37. Next
  38. wb.Close
  39. End If
  40. Next
  41.  
  42. End Sub


Pour le point 2 par contre il faut que tu sois plus précis, je n'arrive pas à comprendre quel est la condition de début de plage.

Pour le point 3, essaye de regarder la fonction "CountA" qui sera très utile ici: https://msdn.microsoft.com/fr-fr/library/office/ff83804...

Edit: corriger un ou deux bug dans la macro ... :pt1cable: 
m
0
l
26 Août 2016 23:21:15

Bonsoir Drul, merci beaucoup :) 
Voici le lien:
fichier source
" alt="" class="imgLz frmImg " />
fichier destination
" alt="" class="imgLz frmImg " />

En fait les critères ont un peu changé:
1- la colonne A peut être vide, et le tableau commence à partir de la colonne B, C ou D...
-Serait-il possible que la macro cherche "affaires" dans les 10 prémières colonnes plutôt que seulement dans A? (ça dépassera pas non plus normalement les 20 premières lignes)
-Une fois affaire trouvée, qu'elle copie les lignes non vides à partir de cette colonne jusqu'à la 16 ème colonne après (par exemple si "affaires" est dans A, copier les lignes non vides de A à P; si "affaires" est dans B, copier les lignes non vides de B à Q etc.
2- In n'y a pas toujours "*(1) Affaire neutralisée par l'aléa DP" à la fin des fichiers.
-En fait il faudra s'arrêter dès qu'on tombe sur un truc contenant "ALEAS" ou "aléas" ( un truc comme ça "* ALEAS *" peut être?)
3- La direction de production n'est pas toujours précisée en fait, et des fois c'est "Dir Production", des fois "Dir Prod", des fois rien.
En fait le plus simple sera de chercher "SOCIETE: " comme on a cherché "affaire" mais sur les 10 premières lignes et 10 premières colonnes, et de mettre le nom de la société à la place de la direction de production. (Il faudra tenir compte du fait que le nom de la société peut être dans les cellules à droite de celle qui contient "SOCIETE").
Si on ne trouve pas la société, mettre le nom du classeur et de l'onglet par défaut, suivi de la copie.
4- Enfin pour la copie, copie spéciale ne copier que les valeurs, ne pas tenir compte des liaisons qu'il y'a dans les fichiers sources ou les formules etc. Respecter les formats des colonnes du fichier de destination préalablement préparés.
N'hésite pas à mettre un peu de commentaires dans le code :) 
Merci encore d'avance pour vos réponses.
m
0
l
a b L Programmation
29 Août 2016 10:33:05

Salut, alors ce n'est pas moi qui ferai ton code tu sais ;) 

Je te donne des pistes, mais c'est à toi de les mettres en oeuvres selon tes besoins.
Le résultat exact que tu cherches à obtenir est loin d'être clair actuellement (tu veux en faire quoi de dir prod ou de société ?)
Le coup du aléa qui peut être écrit de différente façon c'est loin d'être un cadeau, une rigueur à la saisie facilite grandement la réalisation des macros !

Donc pour la recherche de "AFFAIRES" je te propose ceci:

  1. Sub trouve()
  2. Dim maCell As Range
  3. Set maCell = ActiveSheet.UsedRange.Find("AFFAIRES")
  4. If Not (maCell Is Nothing) Then
  5. MsgBox maCell.Row & ":" & maCell.Column
  6. End If
  7. End Sub


Pour aléa, par contre, il faudra faire plus compliqué ...

  1. Sub trouveAlea()
  2. Dim maCell As Range
  3. For Each maCell In ActiveSheet.UsedRange
  4. If LCase(maCell.Value) Like "*al[e,é]a*" Then 'on convertit en minuscule, puis on compare. plus d'info sur like ci-dessous
  5. MsgBox "trouvé ! " & maCell.Row & ":" & maCell.Column
  6. End If
  7. Next
  8. End Sub

L'aide sur l'opérateur "like"
https://msdn.microsoft.com/fr-fr/library/office/gg25179...(v=office.15).aspx

Essaie d'utiliser ceci et reviens avec un code (même non fonctionnel) pour qu'on puisse discuter/corriger de ta solution.
m
0
l
29 Août 2016 19:30:08

Merci beaucoup Drul,
je suis entièrement d'accord avec toi à propos de la rigueur, les filiales ne respectent pas du tout la maquette.
J'ai essayé avec ce code, mais il ne marche pas.
  1. Option Explicit
  2.  
  3. Private moShSynth As Worksheet
  4.  
  5. Public Sub Synthese()
  6.  
  7. Dim sRep As String
  8. Dim oFSO As FileSystemObject
  9. Dim oFic As File
  10. Dim iDerLig As Integer
  11. Dim iCol As Integer
  12. sRep = ChoixDossier
  13.  
  14. If sRep = "" Then
  15. Exit Sub
  16. End If
  17.  
  18. Set oFSO = New FileSystemObject
  19. Set moShSynth = Worksheets("Synthese")
  20.  
  21. 'RAZ
  22. iDerLig = moShSynth.Range("B" & Rows.Count).End(xlUp).Row
  23. If iDerLig >= 8 Then
  24. moShSynth.Rows("8:" & iDerLig).Delete
  25. End If
  26.  
  27. 'parcours du répertoire
  28. For Each oFic In oFSO.GetFolder(sRep).Files
  29. ImportFichier oFic.Path
  30. Next oFic
  31.  
  32. Set oFSO = Nothing
  33. Set moShSynth = Nothing
  34.  
  35. End Sub
  36.  
  37. Private Sub ImportFichier(psFichier As String)
  38.  
  39. Dim oWB As Workbook
  40. Dim oSh As Worksheet
  41.  
  42. Set oWB = Workbooks.Open(psFichier, , True)
  43.  
  44. For Each oSh In oWB.Worksheets 'parcours des onglets
  45.  
  46. If oSh.Visible = xlSheetVisible Then
  47. ImportOnglet oSh
  48. End If
  49. Next oSh
  50.  
  51. oWB.Close False
  52. Set oWB = Nothing
  53.  
  54. End Sub
  55.  
  56. Private Sub ImportOnglet(poSh As Worksheet)
  57.  
  58. Dim bFin As Boolean
  59. Dim iLig As Integer
  60. Const I_MAX As Integer = 20
  61. Dim iEcr As Integer
  62. Dim bAffaireTrouve As Boolean 'commence à partir de "AFFAIRES"
  63. Dim iCol As Integer
  64. 'ligne d'écriture (max colonne B + 1)
  65. iEcr = moShSynth.Range("B" & Rows.Count).End(xlUp).Row + 2
  66.  
  67. Application.ScreenUpdating = False
  68.  
  69. bAffaireTrouve = False
  70. iLig = 1
  71. iCol = 1
  72. bFin = False
  73. While Not bFin
  74. ' If iLig = 10 Then
  75. ' MsgBox "Ligne n°" & iLig, vbExclamation
  76. ' End If_
  77. If poSh.Range(Cells(iCol, iLig)).Value = "*(1) Affaire neutralisée par l'aléa DP " Then
  78. bFin = True
  79. ElseIf iLig >= I_MAX Then
  80. iCol = iCol + 1
  81. bFin = True
  82. ElseIf UCase(Left(poSh.Range(iCol & iLig).Value, 18)) = "SOCIETE :" Then
  83. 'MsgBox iLig, vbExclamation
  84. moShSynth.Range(iCol & iEcr).Value = poSh.Range(iCol & iLig).Value
  85. iLig = iLig + 1
  86. ElseIf UCase(Left(poSh.Range(iCol & iLig).Value, 18)) = "AFFAIRES" Then
  87. bAffaireTrouve = True
  88. iLig = iLig + 2 '2 lignes de titre
  89. ElseIf bAffaireTrouve Then
  90. If LigneRemplie(poSh, iLig) Then
  91. 'écrit toutes les lignes non vides
  92. 'copie et colle la ligne
  93. Dim bout As Integer
  94. bout = iCol + 16
  95. poSh.Range(iCol & iLig & "bout" & iLig).Copy
  96. moShSynth.Range("B" & iEcr).PasteSpecial xlPasteAll
  97. iEcr = iEcr + 1
  98. End If
  99. iLig = iLig + 1
  100. Else
  101. iLig = iLig + 1
  102. End If
  103. Wend
  104.  
  105. Application.ScreenUpdating = True
  106.  
  107. End Sub
  108.  
  109. Private Function LigneRemplie(poSh As Worksheet, piLig As Integer) As Boolean
  110.  
  111. Dim iCol As Integer
  112. Dim bRemplie As Boolean
  113.  
  114. bRemplie = False
  115.  
  116. For iCol = 1 To 16 'A à P
  117. If poSh.Cells(piLig, iCol) <> "" Then
  118. bRemplie = True
  119. Exit For
  120. End If
  121. Next iCol
  122.  
  123. LigneRemplie = bRemplie
  124.  
  125. End Function

Merci d'avance pour vos corrections.
m
0
l
a b L Programmation
29 Août 2016 20:30:30

c'est propre en tous cas ...
dis moi ce qui ne marche pas.
essayes de décomposer, là tu fais tout en même temps, c'est dur à débugger
m
0
l
a b L Programmation
29 Août 2016 20:35:58

poSh.Range(iCol & iLig & "bout" & iLig).Copy
ça c'est pas bon entous cas ...
poSh.Range(poSh.cells(iLig, iCol), poSh.cells(iLig,bout)).Copy 'me paraît mieux ...
m
0
l
29 Août 2016 21:26:39

Merci, j'ai éssayé mais toujours pas bon.
Le message d'erreur est: "La methode Range de l'objet worksheet a échoué"
ça beugue à partir de là
  1. End If_
  2. If poSh.Range(Cells(iCol, iLig)).Value = "*(1) Affaire neutralisée par l'aléa DP " Then
  3. bFin = True
m
0
l
a b L Programmation
30 Août 2016 08:40:58

Erreur de syntaxe, le code correct est: (attention cells (ROW, COL)
  1. End If_
  2. If poSh.Cells(iLig, iCol).Value = "*(1) Affaire neutralisée par l'aléa DP " Then
  3. bFin = True


Ensuite ici:

  1. ElseIf iLig >= I_MAX Then
  2. iCol = iCol + 1
  3. bFin = True

il faut aussi réinitialiser iLig !

Ensuite:
  1. Range(iCol & iLig)

doit être remplacer partout par:
  1. Cells(iLig, iCol)


et ici:

  1. UCase(Left(poSh.Range(iCol & iLig).Value, 18)) = "SOCIETE :"

pourquoi prendre 18 caractères et les comparer à seulement 8 ???
Perso je ferais:
  1. UCase(poSh.Cells(iLig, iCol).Value) like "SOCIETE :*"


Il y a sûrement d'autres erreurs, mais commence déjà par corriger tous ceci et on verra après ... (reposte ton code en indiquant ou ça ne marche pas le cas échéant)
m
0
l
30 Août 2016 19:36:29

Bonsoir Drul,
il n'y a plus de bug dans le code, il fonctionne mais ne fait pas du tout ce que je voudrais qu'il fasse.
1-Il ne copie pas toutes les lignes non vides jusqu'à "*al[é, e]as*" mais s'arrête à la première ligne vide.
2-Il ne copie pas non plus les données de tous les onglets visibles (il copie seulement quand "affaires" est dans la colonne A).
Voici le nouveau code:
  1. Option Explicit
  2.  
  3. Private moShSynth As Worksheet
  4.  
  5. Public Sub Synthese()
  6.  
  7. Dim sRep As String
  8. Dim oFSO As FileSystemObject
  9. Dim oFic As File
  10. Dim iDerLig As Integer
  11. Dim iCol As Integer
  12. sRep = ChoixDossier
  13.  
  14. If sRep = "" Then
  15. Exit Sub
  16. End If
  17.  
  18. Set oFSO = New FileSystemObject
  19. Set moShSynth = Worksheets("Synthese")
  20.  
  21. 'RAZ
  22. iDerLig = moShSynth.Range("B" & Rows.Count).End(xlUp).Row
  23. If iDerLig >= 8 Then
  24. moShSynth.Rows("8:" & iDerLig).Delete
  25. End If
  26.  
  27. 'parcours du répertoire
  28. For Each oFic In oFSO.GetFolder(sRep).Files
  29. ImportFichier oFic.Path
  30. Next oFic
  31.  
  32. Set oFSO = Nothing
  33. Set moShSynth = Nothing
  34.  
  35. End Sub
  36.  
  37. Private Sub ImportFichier(psFichier As String)
  38.  
  39. Dim oWB As Workbook
  40. Dim oSh As Worksheet
  41.  
  42. Set oWB = Workbooks.Open(psFichier, , True)
  43.  
  44. For Each oSh In oWB.Worksheets 'parcours des onglets
  45.  
  46. If oSh.Visible = xlSheetVisible Then
  47. ImportOnglet oSh
  48. End If
  49. Next oSh
  50.  
  51. oWB.Close False
  52. Set oWB = Nothing
  53.  
  54. End Sub
  55.  
  56. Private Sub ImportOnglet(poSh As Worksheet)
  57.  
  58. Dim bFin As Boolean
  59. Dim iLig As Integer
  60. Const I_MAX As Integer = 20
  61. Dim iEcr As Integer
  62. Dim bAffaireTrouve As Boolean 'commence à partir de "AFFAIRES"
  63. Dim iCol As Integer
  64. 'ligne d'écriture (max colonne B + 1)
  65. iEcr = moShSynth.Range("B" & Rows.Count).End(xlUp).Row + 2
  66.  
  67. Application.ScreenUpdating = False
  68.  
  69. bAffaireTrouve = False
  70. iLig = 1
  71. iCol = 1
  72. bFin = False
  73. While Not bFin
  74. ' If iLig = 10 Then
  75. ' MsgBox "Ligne n°" & iLig, vbExclamation
  76. ' End If_
  77. If poSh.Cells(iLig, iCol).Value = "*al[e,é]a*" Then
  78. bFin = True
  79. ElseIf iLig >= I_MAX Then
  80. iCol = iCol + 1
  81. bFin = True
  82. iLig = 1
  83. ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "SOCIETE :*" Then
  84. 'MsgBox iLig, vbExclamation
  85. moShSynth.Cells(iEcr, iCol).Value = poSh.Cells(iLig, iCol).Value
  86. iLig = iLig + 1
  87. ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "AFFAIRES" Then
  88. bAffaireTrouve = True
  89. iLig = iLig + 2 '2 lignes de titre
  90. ElseIf bAffaireTrouve Then
  91. If LigneRemplie(poSh, iLig) Then
  92. 'écrit toutes les lignes non vides
  93. 'copie et colle la ligne
  94. Dim bout As Integer
  95. bout = iCol + 16
  96. poSh.Range(poSh.Cells(iLig, iCol), poSh.Cells(iLig, bout)).Copy
  97. moShSynth.Range("B" & iEcr).PasteSpecial xlPasteAll
  98. iEcr = iEcr + 1
  99. End If
  100. iLig = iLig + 1
  101. Else
  102. iLig = iLig + 1
  103. End If
  104. Wend
  105.  
  106. Application.ScreenUpdating = True
  107.  
  108. End Sub
  109.  
  110. Private Function LigneRemplie(poSh As Worksheet, piLig As Integer) As Boolean
  111.  
  112. Dim iCol As Integer
  113. Dim bRemplie As Boolean
  114.  
  115. bRemplie = False
  116.  
  117. For iCol = 1 To 16 'A à P
  118. If poSh.Cells(piLig, iCol) <> "" Then
  119. bRemplie = True
  120. Exit For
  121. End If
  122. Next iCol
  123.  
  124. LigneRemplie = bRemplie
  125.  
  126. End Function


En fait comme resultat, ça ne copie que ça
" alt="" class="imgLz frmImg " />

Merci encore pour tes réponses
m
0
l
a b L Programmation
30 Août 2016 20:09:00

je regarde demain (dsl on est décalé, je répond le matin, tu bosses le soir ...)

P.S utilises la balise [code="vb"] ... ton code ... [/code] ça met plein de jolie couleur et rend ton code plus lisible pour moi (et m'évite d'avoir à chaque fois à corriger ton post)
m
0
l
30 Août 2016 20:19:48

C'est ok :) 
A demain,
Bonne soirée!
m
0
l
a b L Programmation
31 Août 2016 08:23:04

re,
alors premier problème:
dès que tu as finit la colonne 1, tu quittes ton while:
  1. ElseIf iLig >= I_MAX Then
  2. iCol = iCol + 1
  3. bFin = True ' ici ton quitte ton while, donc on ira jamais voir les autres colonnes ...
  4. ' J'imagine que ce que tu désires ici est: bFin = bAffaireTrouve
  5. iLig = 1

Remarque: ta boucle pourrait être infinie, il serait bon de mettre un J_MAX pour les colonnes, et la tu mets bFin à true.

Ensuite:
  1. If poSh.Cells(iLig, iCol).Value = "*al[e,é]a*" Then

Attention "=" compare si les 2 strings sont strictement égales ! ici c'est l'opérateur "like" qu'il faut utiliser.

Ensuite deux remarque:
1°) "SOCITETE" risque d'être écrasé lors de la copie, puisque tu n'incrémente pas iEcr ...
2°) ta fonction "ligneRemplie" ne marche qui si "AFFAIRE" est en colonne A ! (elle n'est pas "relative" et verifie donc uniquement les colonnes 1 à 16) ...

Une manière de rendre ta fonction relative:
  1. Private Function LigneRemplie2(initCell As Range) As Boolean
  2.  
  3. Dim iCol As Integer
  4. Dim bRemplie As Boolean
  5.  
  6. bRemplie = False
  7.  
  8. For iCol = 0 To 15 '16 colonne depuis initCell (compris)
  9. If initCell.Offset(0, iCol) <> "" Then
  10. bRemplie = True
  11. Exit For
  12. End If
  13. Next iCol
  14.  
  15. LigneRemplie = bRemplie
  16.  
  17. End Function

Que tu appelleras de la manière suivante:
  1. If LigneRemplie2(poSh.Cells(iLig, iCol)) Then



m
0
l
31 Août 2016 21:40:42

Bonsoir Drul,
ça y est le code est opérationnel, tout est presque bon sauf que je ne sais pas comment faire pour incrémenter iEcr pour que "SOCIÉTÉ: " ne soit pas écrasée.
Si tu peux me dire comment faire, ce serait parfait.
Un grand merci encore pour tout.
J'ai rencontré un problème qui n'était pas soulevé jusque là, c'est que les filiales mettent "affaires" dans plusieurs cellules des fois (un peu comme des cellules fusionnées, mais juste l'entête), ce qui fait qu'il peut y avoir des colonnes vides entre les trucs, ou pire encore elles peuvent masquer des colonnes (même si c'est uniquement la partie visible qui nous intéresse, ça reste néanmoins un problème).
Je ne sais pas vraiment quoi faire pour arranger ce bordel.
Et même s'il y'avait un code pour que: sur une ligne non vide donnée, on ne copie que les cellules qui contiennent une valeur et qu'on les colle l'une après l'autre dans le fichier de destination, ça ne resoudrait pas le problèmes puisqu'il y'a des fois des cellules(cases) non renseignées dans le tableau.
Si tu as des idées pour moi, je suis vraiment preneur.
Bonne soirée
m
0
l
a b L Programmation
31 Août 2016 21:44:10

capture d'écran, que je comprenne bien ...
pour societe:
ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "SOCIETE :*" Then
'MsgBox iLig, vbExclamation
moShSynth.Cells(iEcr, iCol).Value = poSh.Cells(iLig, iCol).Value
iLig = iLig + 1
iEcr=iEcr+1
m
0
l
31 Août 2016 21:58:52

Ok les voici:
" alt="" class="imgLz frmImg " />

" alt="" class="imgLz frmImg " />

Merci encore.
m
0
l
a b L Programmation
1 Septembre 2016 07:22:11

Re,

En fait c'est un exemple de ça que j'aurais voulu :
Citation :

J'ai rencontré un problème qui n'était pas soulevé jusque là, c'est que les filiales mettent "affaires" dans plusieurs cellules des fois (un peu comme des cellules fusionnées, mais juste l'entête), ce qui fait qu'il peut y avoir des colonnes vides entre les trucs, ou pire encore elles peuvent masquer des colonnes (même si c'est uniquement la partie visible qui nous intéresse, ça reste néanmoins un problème).
Je ne sais pas vraiment quoi faire pour arranger ce bordel.


Je suis persuadé qu'il y a moyen de gérer ça ...
m
0
l
a b L Programmation
1 Septembre 2016 07:30:21

Remarque: je met permet de te donner une variante plus "compact" de ligneremplie:

  1. Private Function LigneRemplie(initCell As Range) As Boolean
  2. LigneRemplie = Application.WorksheetFunction.CountA(Range(initCell, initCell.Offset(0, 15))) <> 0
  3. End Function
m
0
l
1 Septembre 2016 07:42:04

Bonjour,
C'est un exemple de vrais fichiers les 2 captures d'écran precedentes.
Dans les noms des colonnes, tu verras qu'il y'a des colonnes masquées( D dans l'un et C dans l'autre) et que "AFFAIRES" prends plusieurs colonnes aussi (de A à E, et de A à D).
Je serai dispo dans la journée si besoin de plus de précisions.
Merci Drul!
m
0
l
a b L Programmation
1 Septembre 2016 08:14:03

OK, compris le problème maintenant,
et dans ces cas là tu aimerais quoi comme résultats ? p.ex sur le premier screen on voit "m" en colone B et "5/16" en colonne E, tu aimerais copier quoi ? (on peut, par exemple, copier seulement la première colonne ou concaténer le contenu de toutes les colonnes)
Ton problème principal est que toutes tes colonnes se retrouves décalé sur la récap, c'est bien ça ?

edit: remet ton code stp
m
0
l
1 Septembre 2016 09:45:49

Voilà c'est exactement ça, car dans le fichier de destination nous n'avons prévu qu'une colonne pour "affaires".
Le mieux serait effectivement de concaténer le contenu de toutes les colonnes, et de les mettre dans la colonne "AFFAIRES" du fichier de destination.
Comment on pourrait faire pour le problème des colonnes masquées?
Voici le code avec le dernier point que tu viens d'ajouter, je ne sais pas si je l'ai mis au bon endroit (mais le code marche quand même). Je n'ai pas très bien compris ce que ça fait de plus.
Mais "SOCIETE: " ne s'affiche toujours pas dans le fichier de destination suivie des données correspondantes.
  1. Option Explicit
  2.  
  3. Private moShSynth As Worksheet
  4.  
  5. Public Sub Synthese()
  6.  
  7. Dim sRep As String
  8. Dim oFSO As FileSystemObject
  9. Dim oFic As File
  10. Dim iDerLig As Integer
  11. Dim iCol As Integer
  12. sRep = ChoixDossier
  13.  
  14. If sRep = "" Then
  15. Exit Sub
  16. End If
  17.  
  18. Set oFSO = New FileSystemObject
  19. Set moShSynth = Worksheets("Synthese")
  20.  
  21. 'RAZ
  22. iDerLig = moShSynth.Range("B" & Rows.Count).End(xlUp).Row
  23. If iDerLig >= 8 Then
  24. moShSynth.Rows("8:" & iDerLig).Delete
  25. End If
  26.  
  27. 'parcours du répertoire
  28. For Each oFic In oFSO.GetFolder(sRep).Files
  29. ImportFichier oFic.Path
  30. Next oFic
  31.  
  32. Set oFSO = Nothing
  33. Set moShSynth = Nothing
  34.  
  35. End Sub
  36.  
  37. Private Sub ImportFichier(psFichier As String)
  38.  
  39. Dim oWB As Workbook
  40. Dim oSh As Worksheet
  41.  
  42. Set oWB = Workbooks.Open(psFichier, , True)
  43.  
  44. For Each oSh In oWB.Worksheets 'parcours des onglets
  45.  
  46. If oSh.Visible = xlSheetVisible Then
  47. ImportOnglet oSh
  48. End If
  49. Next oSh
  50.  
  51. oWB.Close False
  52. Set oWB = Nothing
  53.  
  54. End Sub
  55.  
  56. Private Sub ImportOnglet(poSh As Worksheet)
  57.  
  58. Dim bFin As Boolean
  59. Dim iLig As Integer
  60. Const I_MAX As Integer = 1000
  61. Const J_MAX As Integer = 50
  62. Dim iEcr As Integer
  63. Dim bAffaireTrouve As Boolean 'commence à partir de "AFFAIRES"
  64. Dim iCol As Integer
  65. 'ligne d'écriture (max colonne B + 1)
  66. iEcr = moShSynth.Range("B" & Rows.Count).End(xlUp).Row + 2
  67.  
  68. Application.ScreenUpdating = False
  69.  
  70. bAffaireTrouve = False
  71. iLig = 1
  72. iCol = 1
  73. bFin = False
  74. While Not bFin
  75. ' If iLig = 10 Then
  76. ' MsgBox "Ligne n°" & iLig, vbExclamation
  77. ' End If_
  78. If poSh.Cells(iLig, iCol).Value Like "*al[e,é]a*" Then
  79. bFin = True
  80. ElseIf iLig >= I_MAX Then
  81. iCol = iCol + 1
  82. bFin = bAffaireTrouve
  83. iLig = 1
  84. ElseIf iCol >= J_MAX Then
  85. bFin = True
  86. ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "SOCIETE :*" Then
  87. 'MsgBox iLig, vbExclamation
  88. moShSynth.Cells(iEcr, iCol).Value = poSh.Cells(iLig, iCol).Value
  89. iLig = iLig + 1
  90. iEcr = iEcr + 1
  91. ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "AFFAIRES" Then
  92. bAffaireTrouve = True
  93. iLig = iLig + 2 '2 lignes de titre
  94. ElseIf bAffaireTrouve Then
  95. If LigneRemplie(poSh.Cells(iLig, iCol)) Then
  96. 'écrit toutes les lignes non vides
  97. 'copie et colle la ligne
  98. Dim bout As Integer
  99. bout = iCol + 16
  100. poSh.Range(poSh.Cells(iLig, iCol), poSh.Cells(iLig, bout)).Copy
  101. moShSynth.Range("B" & iEcr).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  102. iEcr = iEcr + 1
  103. End If
  104. iLig = iLig + 1
  105. Else
  106. iLig = iLig + 1
  107. End If
  108. Wend
  109.  
  110. Application.ScreenUpdating = True
  111.  
  112. End Sub
  113.  
  114. Private Function LigneRemplie(initCell As Range) As Boolean
  115.  
  116. Dim iCol As Integer
  117. Dim bRemplie As Boolean
  118.  
  119. bRemplie = False
  120.  
  121. For iCol = 0 To 15 '16 colonne depuis initCell (compris)
  122. If initCell.Offset(0, iCol) <> "" Then
  123. bRemplie = True
  124. Exit For
  125. End If
  126. Next iCol
  127.  
  128. LigneRemplie = bRemplie
  129. LigneRemplie = Application.WorksheetFunction.CountA(Range(initCell, initCell.Offset(0, 15))) <> 0
  130. End Function

m
0
l
a b L Programmation
1 Septembre 2016 09:59:25

C'est voulu d'écrire dans la colonne iCol ?
moShSynth.Cells(iEcr, iCol).Value = poSh.Cells(iLig, iCol).Value

T'a un exemple ou on voit SOCIETE ?
Et idéalement aussi un exemple du résultat que tu souhaites obtenir (fait le à la main ...).

Finalement c'est quoi ton soucis avec les cellules cachées ? Tu veux aussi concaténé leur contenu ou non ? faut-il les traiter spécialement ? (de base la macro se fiche que la cellule soit visible ou non, elle passera à travers de toute façon).
m
0
l
1 Septembre 2016 10:24:19

Non c'est pas voulu, le mieux serait de faire comme ça éffectivement.
moShSynth.Range("A" & iEcr).Value = poSh.Cells(iLig, iCol).Value
Voici un exemple de fichier source avec "SOCIETE:"
" alt="" class="imgLz frmImg " />
ce que je voudrai avoir c'est ça:
" alt="" class="imgLz frmImg " />
(A la seule différence que "SOCIETE: " doit être à la place de "Dir Prod: Exemple3" dans la colonne A.
Il ne faut rien copier des cellules cachées en fait, c'est seulement la partie visible qui nous interesse.
Je reste à ta disposition pour plus de précisions.
Merci encore !
Edit:: Ici il y'a 2 colonnes pour "affaires" dans l'imagine du fichier de destination mais j'en supprimerai une pour simplifier le collage.
m
0
l
a b L Programmation
1 Septembre 2016 10:37:18

Ok, alors c'était juste de pas incrémenter iEcr ... tu as réessayer avec: moShSynth.Range("A" & iEcr).Value = poSh.Cells(iLig, iCol).Value ?

ça devrait assez bien le faire ...

Pour AFFAIRES, on s'en occupe après ...

Edit: tiens, je viens de voir un truc ... Dans le classeur SOCIÉTÉ est écris avec des E aigus, dans la macro, il est écrit avec E ...
UCase(poSh.Cells(iLig, iCol).Value) Like "SOCIETE :*"

Essaye de modifié le code pour qu'il soit indépendant des accents (inspire toi de ce que j'ai fait pour ALEA)
m
0
l
1 Septembre 2016 11:28:44

Ok on fait ça, merci !
Mais ça ne marche toujours pas avec "SOCIETE :*" pourtant j'ai éssayé avec accent "SOCIÉTÉ: ", puis comme ça "SOCI[E, É]T[E, É]: " etc.
mais il n'affiche rien dans la colonne A, à savoir pourquoi.
Bonne journée
m
0
l
a b L Programmation
1 Septembre 2016 11:34:52

Laisse l'"*" après le ":"
càd: essaye ça: "*SOCI[E, É]T[E, É]*:*"
Réactive ton msgbox, pour voir s'il le trouve.
m
0
l
1 Septembre 2016 11:43:13

ça y est c'est ok, ça marche bien!
ça fait plaisir, vraiment !
Edit: quand il n'ya pas société(comme c'était le cas avec les 2 vrais fichiers, les filiales sont vraiment pénibles), serait-il possible que ça mette par défaut le nom du classeur suivi de celui de l'onglet à la place de société ?
Merci encore !
m
0
l
a b L Programmation
1 Septembre 2016 12:56:17

Oui c'est faisable, deux solutions (en fait y en a plein d'autre ...):

1) tu déplaces la recherche de société dans une autre boucle (effectuer avant) et si tu n'as pas trouvé de "société" tu écris le nom du classeur.
2) tu mémorises la case dans laquelle tu dois écrire le n° de société, tu crée une variable bSocieteTrouvee et à la fin de ta boucle, si elle est toujours false, alors tu écris, le nom du classeur suivis du nom de l'onglet.

Je te laisse essayer, si tu sèches, demande.
m
0
l
a b L Programmation
1 Septembre 2016 13:12:36

:pt1cable: 

Solution 3: tu écris simplement juste avant la ligne"While Not bFin":

  1. moShSynth.Cells(iEcr, 1).Value = poSh.parent.name &" - " & poSh.name


ce qui fais que de base tu mets le nom du classeur et de la feuille, et dans la boucle, si tu croises société, ben tu le remplace, tout simplement ...

Quel con je fais de pas y avoir pensé tout de suite ...

m
0
l
1 Septembre 2016 19:30:02

Bonsoir Drul,
Merci pour tes réponses,
Je n'ai pas très bien compris pour le nom du classeur et de l'onglet,
mais l'objectif était que la macro trouve le nom du classeur et de l'ongle dont elle copie le contenu, et qu'elle le remplace par "SOCIETE: " si jamais elle la trouve.
Je ne sais pas comment on pourrait appliquer la solution 3 à cela (pour plusieurs classeurs et plusieurs onglets, que faut-il mettre dans &" - "?)
Dans tous les cas, ceci n'est pas le plus important ( à la limite je pourrai créer chaque société un fichier avec ses classeurs), et je les extrais (après avoir mis moi même manuellement le nom de la société). ceci ne devrait pas poser trop de problème. J'appliquerai successivement le code à une dizaine de fichiers alors.
Le plus important ce serait de trouver une solution à ce problème avec "AFFAIRES".
Bonne soirée
m
0
l
a b L Programmation
2 Septembre 2016 07:20:39

Salut, je te propose la solution suivante:

  1. Private Sub ImportOnglet(poSh As Worksheet)
  2.  
  3. Dim bFin As Boolean
  4. Dim iLig As Integer
  5. Dim i As Integer
  6. Const I_MAX As Integer = 1000
  7. Const J_MAX As Integer = 50
  8. Dim iEcr As Integer
  9. Dim bAffaireTrouve As Boolean 'commence à partir de "AFFAIRES"
  10. Dim iCol As Integer
  11. Dim iAffaireSize As Integer 'new variable
  12. Dim sAffaireConc As String 'new variable
  13. 'ligne d'écriture (max colonne B + 1)
  14. iEcr = moShSynth.Range("B" & Rows.Count).End(xlUp).Row + 2
  15.  
  16. Application.ScreenUpdating = False
  17.  
  18. bAffaireTrouve = False
  19. iLig = 1
  20. iCol = 1
  21. bFin = False
  22. moShSynth.Cells(iEcr, 1).Value = poSh.Parent.Name & " - " & poSh.Name
  23. While Not bFin
  24. ' If iLig = 10 Then
  25. ' MsgBox "Ligne n°" & iLig, vbExclamation
  26. ' End If_
  27. If LCase(poSh.Cells(iLig, iCol).Value) Like "*al[e,é]a*" Then
  28. bFin = True
  29. ElseIf iLig >= I_MAX Then
  30. iCol = iCol + 1
  31. bFin = bAffaireTrouve
  32. iLig = 1
  33. ElseIf iCol >= J_MAX Then
  34. bFin = True
  35. ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "*SOCI[E,É]T[E,É]*:*" Then
  36. 'MsgBox iLig, vbExclamation
  37. moShSynth.Cells(iEcr, 1).Value = poSh.Cells(iLig, iCol).Value
  38. iLig = iLig + 1
  39. iEcr = iEcr + 1
  40. ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "AFFAIRES" Then
  41. iAffaireSize = poSh.Cells(iLig, iCol).End(xlToRight).Column - poSh.Cells(iLig, iCol).Column 'on détermine la taille de la colonne affaire
  42. bAffaireTrouve = True
  43. iLig = iLig + 2 '2 lignes de titre
  44. ElseIf bAffaireTrouve Then
  45. If LigneRemplie(poSh.Cells(iLig, iCol), 14 + iAffaireSize) Then 'le nombre de colonne à vérifier dépend de la taille de la colonne affaire
  46. 'écrit toutes les lignes non vides
  47. 'copie et colle la ligne
  48. sAffaireConc = "" 'initialisation de la somme de toutes les case de la colonne affaire
  49. For i = 0 To (iAffaireSize - 1) 'pour chaque cellule de la colonne affaire
  50. If poSh.Cells(iLig, iCol + i).EntireColumn.Hidden = False Then 'si les cellules sont visibles
  51. sAffaireConc = sAffaireConc & poSh.Cells(iLig, iCol + i).Value 'on concatène
  52. End If
  53. Next
  54. moShSynth.Range("B" & iEcr).Value = sAffaireConc
  55. Dim bout As Integer
  56. bout = iCol + iAffaireSize + 15 ' on tient ompte de la taille de la colonne affaire
  57. poSh.Range(poSh.Cells(iLig, iCol + iAffaireSize), poSh.Cells(iLig, bout)).Copy 'ici aussi
  58. moShSynth.Range("C" & iEcr).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  59. iEcr = iEcr + 1
  60. End If
  61. iLig = iLig + 1
  62. Else
  63. iLig = iLig + 1
  64. End If
  65. Wend
  66.  
  67. Application.ScreenUpdating = True
  68.  
  69. End Sub
  70. Private Function LigneRemplie(initCell As Range, Offset As Integer) As Boolean ' J'ai rajouter offset
  71. LigneRemplie = Application.WorksheetFunction.CountA(Range(initCell, initCell.Offset(0, Offset))) <> 0
  72. End Function


J'ai mis quelques commentaire, si qqch n'est pas claire, redit moi.
m
0
l
2 Septembre 2016 12:12:47

Bonjour Drul,
je n'arrive pas à executer la macro, ça me met "Impossible d'"executer la macro "...." Il est possible qu'elle ne soit pas disponible dans ce classeur ou que toutes les macros soient désactivée.
Qu'est ce qu'il faut que je fasse?
Merci beaucoup
m
0
l
a b L Programmation
2 Septembre 2016 13:03:51

Il faut garder les autres fonctions: càd:
  1. Option Explicit
  2.  
  3. Private moShSynth As Worksheet
  4.  
  5. Public Sub Synthese()
  6.  
  7. Dim sRep As String
  8. Dim oFSO As FileSystemObject
  9. Dim oFic As File
  10. Dim iDerLig As Integer
  11. Dim iCol As Integer
  12. sRep = ChoixDossier
  13.  
  14. If sRep = "" Then
  15. Exit Sub
  16. End If
  17.  
  18. Set oFSO = New FileSystemObject
  19. Set moShSynth = Worksheets("Synthese")
  20.  
  21. 'RAZ
  22. iDerLig = moShSynth.Range("B" & Rows.Count).End(xlUp).Row
  23. If iDerLig >= 8 Then
  24. moShSynth.Rows("8:" & iDerLig).Delete
  25. End If
  26.  
  27. 'parcours du répertoire
  28. For Each oFic In oFSO.GetFolder(sRep).Files
  29. ImportFichier oFic.Path
  30. Next oFic
  31.  
  32. Set oFSO = Nothing
  33. Set moShSynth = Nothing
  34.  
  35. End Sub
  36.  
  37. Private Sub ImportFichier(psFichier As String)
  38.  
  39. Dim oWB As Workbook
  40. Dim oSh As Worksheet
  41.  
  42. Set oWB = Workbooks.Open(psFichier, , True)
  43.  
  44. For Each oSh In oWB.Worksheets 'parcours des onglets
  45.  
  46. If oSh.Visible = xlSheetVisible Then
  47. ImportOnglet oSh
  48. End If
  49. Next oSh
  50.  
  51. oWB.Close False
  52. Set oWB = Nothing
  53.  
  54. End Sub


Et coller ce que je t'ai mis après
m
0
l
2 Septembre 2016 14:50:28

Waw, très très fort!
Merci Monsieur!
ça marche très bien!
m
0
l

Meilleure solution

a b L Programmation
2 Septembre 2016 15:33:43

Bon, ben si t'as pas d'autres questions tu peux selectioner une meilleure solution pour clore ce roman ;) 
partage