Aide macro

Fermé

xav37300 Messages postés 46 Date d'inscription mercredi 18 décembre 2013 Statut Membre Dernière intervention 4 septembre 2019 - 3 sept. 2019 à 21:35
Frenchie83 Messages postés 2240 Date d'inscription lundi 6 mai 2013 Statut Membre Dernière intervention 11 août 2023 - 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

A voir également:

Aide macro
Macro word - Guide
Macro logiciel - Télécharger - Organisation
Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
Macro recorder - Télécharger - Confidentialité
Macro souris ✓ - Forum Windows

2 réponses

Réponse 1 / 2

Frenchie83 Messages postés 2240 Date d'inscription lundi 6 mai 2013 Statut Membre Dernière intervention 11 août 2023 337
4 sept. 2019 à 01:59

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
4 sept. 2019 à 08:02

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

Réponse 2 / 2

Frenchie83 Messages postés 2240 Date d'inscription lundi 6 mai 2013 Statut Membre Dernière intervention 11 août 2023 337
4 sept. 2019 à 08:38

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

Discussions similaires

Transformer un chiffre en lettres dans excel sans macro

Copie automatique tableau Excel sans macro

recup couleur de cellule sans macro

Lien de téléchargement de nbLettre.xla

tri automatque sur excel sans créer de macro

Discussions similaires

Newsletters