Macro pour création de deux fichiers Excel

[stephcic]

Bonjour à tous,
je suis nouveau sur ce forum et j'espère pouvoir trouver une solution à mon problème.

Voilà, j'ai un fichier Excel avec une feuille 'Données'.
et j'aimerais par macro (style un bouton) pouvoir :
créer, à partir de cette feuille 'Données',deux autres fichiers reprenant certaines colonnes de la feuille 'Données' en fonction d'un critère :

si la valeur de la cellule en colonne A=RESEAU, alors tu m'envoies les données des colonne A,B et C dans une feuille 'Données' d'un fichier 'RESEAU'

si la valeur de la cellule en colonne A=SIEGE, alors tu m'envoies les données des colonne B, D, E et C dans une feuille 'Données' d'un fichier 'RESEAU'

jespère avoir bien exposé ma problématique et je vous remercie par avance pour vos éléments de réponse

Stephane

 

[PMO2]

Re : Macro pour création de deux fichiers Excel

Bonjour,

Une solution avec le code suivant à copier dans un module standard
Adaptez éventuellement les constantes (cernées par des ###)

'#### A adapter selon votre usage ###
Const FEUILLE_SOURCE As String = "Données"
Const MY_RESEAU As String = "RESEAU"
Const MY_SIEGE As String = "SIEGE"
'####################################

Sub MakeReseauSiege()
Dim WBD As Workbook 'classeur Données source
Dim WBR As Workbook 'classeur RESEAU ou SIEGE
Dim NeoClasseurs
Dim S As Worksheet
Dim lastRow&
Dim i&
Dim k&
Dim var
NeoClasseurs = Array(MY_RESEAU, MY_SIEGE)
Set WBD = ActiveWorkbook
On Error Resume Next
Set S = WBD.Sheets(FEUILLE_SOURCE)
If Err <> 0 Then
  MsgBox "La feuille ''" & FEUILLE_SOURCE & "'' est introuvable"
  Exit Sub
End If
On Error GoTo Erreur
lastRow& = S.[a65536].End(xlUp).Row
var = S.Range("a1:a" & lastRow& & "")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For k& = LBound(NeoClasseurs) To UBound(NeoClasseurs)
  Set WBR = Workbooks.Add(xlWBATWorksheet)
  WBD.Sheets(FEUILLE_SOURCE).Copy After:=WBR.Sheets(1)
  WBR.Sheets(1).Delete
  Set S = WBR.ActiveSheet
  S.Name = S.Name & "_" & NeoClasseurs(k&)
  For i& = lastRow& To 1 Step -1
    If var(i&, 1) <> NeoClasseurs(k&) Then
      S.Rows(i&).Delete
    End If
  Next i&
  Select Case k&
    Case 0
      S.Columns("D:IV").Delete
    Case 1
      S.Range("A:A,F:IV").Delete
      S.Columns("B:B").Cut
      S.Columns("E:E").Select
      S.Paste
      S.Columns("B:B").Delete
  End Select
  S.[a1].Select
Next k&
Erreur:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur : " & Err.Number & _
     vbCrLf & Err.Description
End Sub

Une fois le code copié, lancez la macro "MakeReseauSiege"
Cela va créer 2 classeurs (RESEAU et SIEGE) conformes à votre demande.

Cordialement.

PMO
Patrick Morange