Discussion :

[Groggy78]

Bonjour à tous,


Fervent lecteur de ce forum, je me décide enfin à demander de l'aide car je n'ai trouvé nul part la réponse à mon problème.
Je remercie par avance toutes les personnes qui essaieront de m'aider sur cette problématique.

Explication:
J'ai un fichier excel (vous le trouverez ci-joint) avec plusieurs feuilles.
Ma première feuilles "Calculs" sera composée d'informations diverses et variées d'entreprise que je me chargerai de collecter. Ces entreprises font partie d'un secteur d'activité particulier (Banque, Industrie, Distribution, Mutuelle, Assurance, Industrie,...)
Sur cette feuille les lignes 31 à 38 seront des formules (Si l'entreprise que je viens de renseigner est une banque alors je mets 1 sur ma ligne 31 sinon "" et ainsi de suite).
Cette feuille s'arrêtera systématique à ligne 103 en revanche pourra comporter X colonnes (en fonction des données que j'aurai collectées).
Les autres feuilles (CalculsBAM = Banque Assurance Mutuelle, CalculsB = Banque, ...) doivent collecter les données de ma feuilles "calculs" si... c'est une banque, une assurance ...
Exemple:
Dans ma feuille BAM je dois retrouver toutes les banques, assurances et mutuelles présentent dans la feuille "Calculs" ainsi que leurs informations
Dans ma feuille AM je dois retrouver toutes les assurances et mutuelles ...

Ce que je cherche à faire:
Je cherche une macro serait capable de faire ceci:
Si B31=1 ou B32=1 ou B33=1 alors je copie la colonne B et je la colle dans la feuille CalculsBAM au niveau de la première colonne vide (et ceci bien sur pour toutes les colonnes de ma feuille "Calculs" à partir de la colonne B.
Si B=31 alors je copie la colonne B et je la colle dan le feuille CalculsB
Ect...

Dans le fichier joint je vous ai mis 4 exemples dans ma feuille Calcul (sans renseigner toutes les informations) c'est juste pour que vous compreniez bien.
Si je ne suis pas clair dans mes explications n'hésitez pas à me le faire savoir.

Merci à tous pour votre aide et le temps que vous me consacrerez.
Amicalement,

[Mr Poulpe]

Bonjour,

Essaie un truc comme ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Option Explicit
Sub copier()
Application.ScreenUpdating = False
Dim i, j As Integer
Dim Wks_cible As Worksheet
j = 2
While Sheets("Calculs").Cells(1, j) <> ""
    For i = 31 To 38
        If Sheets("Calculs").Cells(i, j) = 1 Then
            Set Wks_cible = Trouver_feuille(Sheets("Calculs").Cells(i, 1))
            If Not Wks_cible Is Nothing Then
                Sheets("calculs").Cells(1, j).EntireColumn.Copy
                Wks_cible.Paste Destination:=Wks_cible.Cells(1, 16000).End(xlToLeft).Offset(0, 1)
            Else
                MsgBox "Aucune feuille n'a été associée à l'entête : " & Sheets("calculs").Cells(i, 1)
            End If
        End If
    Next i
    j = j + 1
Wend
Application.ScreenUpdating = True
End Sub
 
 
Function Trouver_feuille(En_tete_de_ligne As String) As Worksheet
Select Case En_tete_de_ligne
    Case "Banque?"
        Set Trouver_feuille = ThisWorkbook.Sheets("CalculsB")
    Case "Assurance?"
        Set Trouver_feuille = ThisWorkbook.Sheets("CalculsA")
    Case "Mutuelle?"
        Set Trouver_feuille = ThisWorkbook.Sheets("CalculsM")
    Case "Banque ou assurance ou Mutuelle?"
        Set Trouver_feuille = ThisWorkbook.Sheets("CalculsBAM")
 
    'A compléter ici selon la feuille de destination
    '...
    '...
    '...
    Case Else
        Set Trouver_feuille = Nothing
End Select
End Function

Poulpe

[Groggy78]

Salut Mr Poulpe,


Je te renouvelle mes remerciements pour ta proposition.
Malheureusement cela ne fonctionne pas "parfaitement". C'est à dire que tout se passe bien, aucun problème de bug, c'est la répartition qui n'est pas bonne.
Et je me suis rendu compte que c'est de ma faute je me suis mal exprimé.
Donc le plus simple c'est que tu regardes l'exemple que j'ai mis en PJ. J'ai volontairement caché des lignes car elles ne nous intéressent pas pour créer la macro.

Encore merci pour ton aide.
Bonne fin de journée,

[Mr Poulpe]

Bonsoir,

Si j'ai bien compris, ceci devrait aider.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
Option Explicit
Sub copier()
Application.ScreenUpdating = False
Dim i, j As Integer
Dim Wks_cible As Worksheet
j = 2
While Sheets("Calculs").Cells(1, j) <> ""
    For i = 31 To 38 'Remplacer ici le 31 à 38 par l'intervalle de lignes concernées pour savoir où copier les feuilles
        If Sheets("Calculs").Cells(i, j) = "Oui" Then
            Set Wks_cible = Sheets(Sheets("Calculs").Cells(i, 1))
            If Not Wks_cible Is Nothing Then
                Sheets("calculs").Cells(1, j).EntireColumn.Copy
                Wks_cible.Paste Destination:=Wks_cible.Cells(1, 16000).End(xlToLeft).Offset(0, 1)
            Else
                MsgBox "Aucune feuille n'a été associée à l'entête : " & Sheets("calculs").Cells(i, 1)
            End If
        End If
    Next i
    j = j + 1
Wend
Application.ScreenUpdating = True
End Sub

Remplace juste le 'for i = 31 to 38' par l'intervalle de lignes qui disent sur quelles feuilles il faut copier (les numéros de lignes de calculs BAM à calculs M sur ton exemple.
Le nom de feuille rempli en colonne A doit être exactement le même que le nom de la feuille sur laquelle il faut copier.

C'est pas testé, mais je pense que ça marche.

Poulpe

[Groggy78]

Bonjour Poulpe,

J'ai adapté ta Macro comme tu me l'as dit.
En revanche lorsque je l'exécute il me met :

Erreur d'exécution '13' - Incompatibilité de type

Et ceci pour la ligne ci dessous:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Set Wks_cible = Sheets(Sheets("Calculs").Cells(i, 1))

J'ai eu beau chercher je ne comprends pas pourquoi. Tu as une idée ?

Merci d'avance et bonne journée.

[Mr Poulpe]

Hum peut être qu'il faudrait essayer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set Wks_cible = Sheets(Sheets("Calculs").Cells(i, 1).value)

Si ça ne marche pas, pourrais-tu joindre le fichier pour test svp?

Poulpe