Macro élection/collage tableau en fonction d'un critère Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
K
Kepler
Nouveau venu
Nouveau venu
Messages : 3
Inscrit le : 2 juillet 2014
Version d'Excel : 2010 EN

Message par Kepler » 9 novembre 2015, 14:02

Bonjour à tous,

j'ai une macro VBA à faire dont le but est de copier des lignes suivant un texte qui les précèdent et de les copier les unes à la suite des autres dans une feuille qui leur correspond. Le texte en question est "BLOC1", "BLOC2", [...], "BLOC9" qui est suivi d'un certain nombre de lignes (à copier). Les "BLOCX" peuvent apparaitre plusieurs fois dans le fichier, ils doivent dans ce cas être placés les uns à la suite des autres dans la feuille correspondante.

J'ai cherché une solution pour recherche le texte en question, sélectionner le texte depuis la cellule suivante jusqu'au texte suivant mais je n'ai rien programmé de concluant. J'ai joint un fichier qui contient des explications qui vous aideront à mieux cerner le problème.

Un grand merci à celui qui pourra m'apporter son aide ! :)

PS: j'ai recherché sur le forum des situations similaires sans toutefois réussir à les adapter.
KeplerExemple.xlsm
(21.77 Kio) Téléchargé 25 fois
Avatar du membre
bigdaddy154
Membre impliqué
Membre impliqué
Messages : 1'067
Appréciations reçues : 29
Inscrit le : 5 mars 2014
Version d'Excel : 2010

Message par bigdaddy154 » 9 novembre 2015, 15:26

Bonjour,

un essai voir si cela te convient.

Cordialement.

:btres:
KeplerExemple.xlsm
(29.11 Kio) Téléchargé 23 fois
Avatar du membre
Klin89
Membre dévoué
Membre dévoué
Messages : 595
Appréciations reçues : 21
Inscrit le : 28 mai 2011
Version d'Excel : 2003 FR

Message par Klin89 » 9 novembre 2015, 21:24

Bonsoir le forum, :)

Une autre version :
Option Explicit

Sub Copier()
Dim myAreas As Areas, myArea As Range, derlig As Long, feuille As String
    Application.ScreenUpdating = False
    On Error Resume Next
    Set myAreas = Sheets("Base").Columns(1).SpecialCells(2, 1).Areas
    On Error GoTo 0
    If myAreas Is Nothing Then Exit Sub
    For Each myArea In myAreas
        feuille = myArea.Cells(0)
        With Sheets(feuille)
            derlig = .Range("A" & Rows.Count).End(xlUp).Row
            If derlig = 1 Then
                myArea.Resize(, 4).Copy .Cells(1, 1)
            Else
                myArea.Resize(, 4).Copy .Cells(derlig + 1, 1)
            End If
        End With
    Next
    Set myAreas = Nothing
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
End Sub
klin89
K
Kepler
Nouveau venu
Nouveau venu
Messages : 3
Inscrit le : 2 juillet 2014
Version d'Excel : 2010 EN

Message par Kepler » 10 novembre 2015, 09:05

Merci bigdaddy154 et Klin89, vos solutions me conviennent toutes les deux !
C'est exactement le résultat que je recherchais et vos macro sont de plus facile à adapter.

:merci:
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message