Aide macro

Messages postés
46
Date d'inscription
mercredi 18 décembre 2013
Statut
Membre
Dernière intervention
4 septembre 2019
- - Dernière réponse : Frenchie83
Messages postés
1991
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
16 septembre 2019
- 4 sept. 2019 à 08:38
Bonjour,

Je me permets de vous contacter pour vous demander votre aide sur un fichier que je dois travailler tous les mois ligne par ligne.
En effet, tous les mois, je fais une extraction d'un logiciel (dont je vous joints un exemple du fichier = fichier brut )que je modifie à la main et qui me prend beaucoup de temps afin d'obtenir le fichier modifié.
J'aimerais pouvoir obtenir, à l'aide d'un bouton par exemple, la présentation du fichier modifié directement afin de pouvoir gagné du temps.

https://www.cjoint.com/c/IIdtG03wjpp

Pour aider dans l'analyse, je souhaiterais aussi que dans la colonne A lorsque la case est vide qu'il me reprenne l’entête de l 'info qu'il y a en S7 ,S14, S44....(sur le tableau de l'onglet fichier Brut)

Merci encore pour votre aide



Configuration: Windows / Chrome 76.0.3809.132
Afficher la suite 

2 réponses

Messages postés
1991
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
16 septembre 2019
224
0
Merci
Bonjour,

Ceci:
https://mon-partage.fr/f/ftiTdIcR/

le code
Sub Transfert()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, Lig_f2 As Long
    Dim Ville As String
    
    Application.ScreenUpdating = False
    Set f1 = Sheets("fichier brut")
    Set f2 = Sheets("fichier modifié")
    f2.Range(f2.Cells(7, "A"), f2.Cells(1000, "AA")).ClearContents
    DerLig_f1 = f1.[A10000].End(xlUp).Row
    Lig_f2 = 7
    For i = 7 To DerLig_f1
        If Cells(i, "S").Font.ColorIndex = 3 Then
            Ville = Cells(i, "S")
            i = i + 4
            Do While f1.Cells(i, "S").Font.ColorIndex <> 3
                If Cells(i, "C") <> "" And Cells(i, "C").Font.ColorIndex = 1 Then
                    f2.Cells(Lig_f2, "A") = Ville
                    f1.Range(Cells(i, "C"), Cells(i, "AA")).Copy Destination:=f2.Cells(Lig_f2, "C")
                    Lig_f2 = Lig_f2 + 1
                End If
                i = i + 1
                If i > DerLig_f1 Then Exit Sub
            Loop
        End If
        i = i - 1
    Next i
End Sub



Cdlt
xav37300
Messages postés
46
Date d'inscription
mercredi 18 décembre 2013
Statut
Membre
Dernière intervention
4 septembre 2019
-
Bonjour,

Merci beaucoup par contre j'ai un problème car quand il s'agit des entêtes correct le fichier plante (ci dessous le fichier)
https://www.cjoint.com/c/IIegapckJPp
Est ce que vous pensez que cela peut être du au fait que la donnée à transférer n'est pas une Ville (sur votre fichier en changeant la ville avec d'autres données cela fonctionné)

Merci à vous
Commenter la réponse de Frenchie83
Messages postés
1991
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
16 septembre 2019
224
0
Merci
Bonjour,

Est ce que vous pensez que cela peut être du au fait que la donnée à transférer n'est pas une Ville Non, c'est parce que je me suis basé à la couleur rouge de la ville et qui n'existe pas dans le fichier réel.

Voici la correction

Sub Transfert()
    Dim f1 As Worksheet, f2 As Worksheet
    Dim DerLig_f1 As Long, Lig_f2 As Long
    Dim Ville As String
    
    Application.ScreenUpdating = False
    Set f1 = Sheets("fichier brut")
    Set f2 = Sheets("fichier modifié")
    f2.Range(f2.Cells(7, "A"), f2.Cells(1000, "AA")).ClearContents
    DerLig_f1 = f1.[A10000].End(xlUp).Row
    Lig_f2 = 7
    For i = 7 To DerLig_f1
        i = i - 1
        If f1.Cells(i, "A") = "Entité" Then
            Ville = f1.Cells(i + 1, "S")
            i = i + 5
            Do While f1.Cells(i, "A") <> "Entité"
                If f1.Cells(i, "C") <> "" And f1.Cells(i, "C").Font.ColorIndex = 1 Then
                    f2.Cells(Lig_f2, "A") = Ville
                    f1.Range(f1.Cells(i, "C"), f1.Cells(i, "AA")).Copy Destination:=f2.Cells(Lig_f2, "C")
                    Lig_f2 = Lig_f2 + 1
                End If
                i = i + 1
                If i > DerLig_f1 Then Exit Sub
            Loop
        End If
    Next i
End Sub


le fichier
https://mon-partage.fr/f/or3mME9O/

Cdlt
Commenter la réponse de Frenchie83