Macro à partir de plusieurs onglets pour concatener cellules

Le 30/06/2011 à 11:49

Bonjour forum,

J'utilise une macro pour concaténer des cellules de la Feuille 1 et les coller dans la 2.

Je voudrais maintenant que la macro aille chercher les données à concatener dans plusieurs feuilles (4 au total, feuille 1 comprise), et qu'elle les colle toutes dans une seule feuille, les lignes à la suite les unes des autres.

Voici la macro en question :

Option Explicit

Sub perfect_steering()

Dim I As Integer

Dim J As Long

Dim K As Byte

Dim Lg As Long

Dim Msg As String

Dim ColDep

Dim ColFin

ColDep = Array(5, 35, 47, 50)

ColFin = Array(34, 46, 49, 61)

Lg = 4

If Range("A1") <> "" Then

Lg = Range("A" & Rows.Count).End(xlUp).Row

End If

With Sheets("Result A.R. Steering plans")

For J = 11 To .Range("A" & .Rows.Count).End(xlUp).Row

For K = 0 To UBound(ColDep)

Msg = ""

For I = ColDep(K) To ColFin(K)

If .Cells(J, I) <> "" And UCase(.Cells(J, I)) <> "OK" And UCase(.Cells(J, I)) <> "KO" Then

Msg = Msg & .Cells(J, I) & ","

End If

Next I

If Len(Msg) > 0 Then

Cells(Lg, 2 + K) = Left(Msg, Len(Msg) - 1)

End If

Next K

Lg = Lg + 1

Next J

End With

Columns("B:E").AutoFit

End Sub

Merci pour votre aide !

Pierrot

Le 30/06/2011 à 11:57

Bonjour pierrot,

Si les 4 feuilles à concaténer se trouvent toutes à gauche de la feuille de synthèse, essaie avec ce code (sans fichier pas facile de tester) :

Option Explicit

Sub perfect_steering()
Dim I As Integer
Dim J As Long
Dim K As Byte
Dim Lg As Long
Dim Msg As String
Dim ColDep
Dim ColFin

ColDep = Array(5, 35, 47, 50)
ColFin = Array(34, 46, 49, 61)

Lg = 4

If Range("A1") <> "" Then
Lg = Range("A" & Rows.Count).End(xlUp).Row
End If

For aze = 1 To 4

With Sheets(I)
For J = 11 To .Range("A" & .Rows.Count).End(xlUp).Row
For K = 0 To UBound(ColDep)
Msg = ""
For I = ColDep(K) To ColFin(K)
If .Cells(J, I) <> "" And UCase(.Cells(J, I)) <> "OK" And UCase(.Cells(J, I)) <> "KO" Then
Msg = Msg & .Cells(J, I) & ","
End If
Next I
If Len(Msg) > 0 Then
Cells(Lg, 2 + K) = Left(Msg, Len(Msg) - 1)
End If
Next K
Lg = Lg + 1
Next J
End With

Next aze

Columns("B:E").AutoFit
End Sub
Le 30/06/2011 à 13:25

Bonjour vba new

Merci pour ce code, mais une fois collé il ne fonctionne pas. Je te propose mon fichier et la photo de la ligne bloquante, en espérant que cela pourra aider !

Le 30/06/2011 à 14:08

J'avais pas vu que le I était déjà utilisé. J'ai pas encore ouvert ton fichier excel mais reteste avec le code édité ci-dessus.

Le 30/06/2011 à 14:18

Bonjour,

J'ai essayé mais il semble que la var aze ne soit pas définie ...

Je précise que les 4 onglets sont à la suite (pas dans le modèle dont l'url est jointe où il n'y a qu'un onglet pour montrer la structure du doc, mais "en vrai").

Pour ces 4 onglets, les concatenate commencent tous dans la cellule G14.

Avec le code que tu m'as montré, tu ne crois pas que les lignes risquent de se superposer ?

Merci pour ton aide

-- 30 Juin 2011, 15:40 --

Please help, je suis bloqué !

Je peux fournir plus d'info si nécessaire, il n'y a qu'à me demander.

Le 01/07/2011 à 12:09

Sur chacun des 4 onglets, les données à concatener commencent en G14, il ne faut pas que la macro tienne compte des KO et des OK.

Autre contrainte, d'une feuille à l'autre, les "types" n'ont pas la même longueur, ils n'ont pas le même nombre de colonnes.

En revanche, il y a toujours 4 types par feuille, même s'ils sont de longueurs différentes. Il faut peut-être créer 4 ColDep / ColFin ?

Enfin, il faudrait que sur la feuille de résultat (appelée "result macro"), le nom du "pack" apparaisse dans la colonne A, à gauche des listes correspondantes.

J'espère qu'on y arrivera, je sens qu'on est vraiment près du but !

D'avance, un grand merci !

Cordialement,

-- Pierrot --

Le 01/07/2011 à 13:41

Bonjour

A voir

143pierrot-42-concatene-v003.xlsm (96.78 Ko)
Le 01/07/2011 à 15:16

Bonjour Banzai,

Merci beaucoup, ça tourne impeccable !

J'ai une dernière question stp : parfois les "packs" sont séparés par des lignes vides dans mon vrai fichier, serait-il possible, dans la feuille de résultat, d'effacer ces lignes vides afin de ne présenter que les non vides ?

Par exemple, dans la feuille 1, on peut avoir :

Nom du pack

aa

bb

rien

rien

rien

cc

rien

dd

Voici mon code, avec les quelques modif que j'ai faites :

Option Explicit

Sub perfect_steering()
Dim I As Integer
Dim J As Long
Dim K As Byte
Dim F As Byte
Dim Lg As Long
Dim Msg As String
Dim Titre
Dim ColDep
Dim ColFin
Dim Cel As Range

  Application.ScreenUpdating = False
  Titre = Array("Read permission on activity planning", "Write permission on activity planning", "Read permission on synchronisation parts", "Write permission on synchronisation parts")
  ReDim ColDep(UBound(Titre))
  ReDim ColFin(UBound(Titre))

  Lg = Range("A" & Rows.Count).End(xlUp).Row + 1
  If Lg > 6 Then
    Range("A6:E" & Lg).ClearContents
  End If
  Lg = 6

  For F = 13 To 16

    With Sheets(F)
      For I = 0 To UBound(Titre)
        Set Cel = .Rows(11).Find(what:=Titre(I), LookIn:=xlValues, lookat:=xlWhole)
        If Not Cel Is Nothing Then
          ColDep(I) = Cel.Column
          J = Cel.Column
          While .Cells(11, J).MergeCells = True And .Cells(11, J + 1) = ""
            J = J + 1
          Wend
          ColFin(I) = J
        Else
          MsgBox "Incorrect data format in the sheet " & .Name
          Exit Sub
        End If
      Next I

      For J = 14 To .Range("C" & .Rows.Count).End(xlUp).Row
        If .Range("D" & J) <> "" Then
          For K = 0 To UBound(ColDep)
            Msg = ""
            For I = ColDep(K) To ColFin(K)
              If .Cells(J, I) <> "" And UCase(.Cells(J, I)) <> "OK" And UCase(.Cells(J, I)) <> "KO" Then
                Msg = Msg & .Cells(J, I) & ","
              End If
            Next I
            If Len(Msg) > 0 Then
              Cells(Lg, "A") = .Range("C" & J)
              Cells(Lg, 2 + K) = Left(Msg, Len(Msg) - 1)
            End If
          Next K
          Lg = Lg + 1
        End If
      Next J
    End With
  Next F
  Columns("A:E").AutoFit
End Sub

Encore un grand merci Banzai, de ma part et de celle de mes collègues

Le 01/07/2011 à 16:32

Bonjour

As tu essayé le code en insérant des lignes vierges ?

Car cette partie est faite pour sauter les lignes vierges

If .Range("D" & J) <> "" Then

A suivre

Le 01/07/2011 à 16:43

Merci de ta réactivité,

En fait les lignes sans valeurs des 4 feuilles sources ne sont pas exactement vides, car leurs cellules contiennent des formules dont le résultat est 'rien', donc ces cellules ont l'air vide, mais le code les prend peut-être tout de même en compte à cause de cela.

Comment contourner ce pb ? Serait-il possible d'adapter le code pour que, une fois les concaténations terminées, les lignes vides dans la feuille de résultat soient supprimées ?

Le 01/07/2011 à 17:27

Bonjour

Dans la feuille "Sheet 1" il y a bien une formule en D22 (comme résultat "") et cette ligne (22) n'est pas interprétée

Envoies un exemple (dans un fichier) pour que je teste

A suivre

Le 04/07/2011 à 11:08

Bonjour Forum, salut Bonzai, salut vba_new

J'ai enfin le résultat attendu, c'est bluffant, je vous dit à tous un grand merci ! De la part des collègues aussi, qui vont également profiter de ce travail.

Je colle à la suite le code, adapté à mon "vrai" fichier :

Option Explicit

Sub perfect_steering()

Dim I As Integer

Dim J As Long

Dim K As Byte

Dim F As Byte

Dim Lg As Long

Dim Msg As String

Dim Titre

Dim ColDep

Dim ColFin

Dim Cel As Range

Application.ScreenUpdating = False

Titre = Array("Type 1", "Type 2", "Type 3", "Type 4")

ReDim ColDep(UBound(Titre))

ReDim ColFin(UBound(Titre))

Lg = Range("A" & Rows.Count).End(xlUp).Row + 1

If Lg > 6 Then

Range("A6:E" & Lg).ClearContents

End If

Lg = 6

For F = 13 To 16

With Sheets(F)

For I = 0 To UBound(Titre)

Set Cel = .Rows(11).Find(what:=Titre(I), LookIn:=xlValues, lookat:=xlWhole)

If Not Cel Is Nothing Then

ColDep(I) = Cel.Column

J = Cel.Column

While .Cells(11, J).MergeCells = True And .Cells(11, J + 1) = ""

J = J + 1

Wend

ColFin(I) = J

Else

MsgBox "Incorrect data format in the sheet " & .Name

Exit Sub

End If

Next I

For J = 14 To .Range("C" & .Rows.Count).End(xlUp).Row

If .Range("G" & J) <> "" Then

For K = 0 To UBound(ColDep)

Msg = ""

For I = ColDep(K) To ColFin(K)

If .Cells(J, I) <> "" And UCase(.Cells(J, I)) <> "OK" And UCase(.Cells(J, I)) <> "KO" Then

Msg = Msg & .Cells(J, I) & ","

End If

Next I

If Len(Msg) > 0 Then

Cells(Lg, "A") = .Range("C" & J)

Cells(Lg, 2 + K) = Left(Msg, Len(Msg) - 1)

End If

Next K

Lg = Lg + 1

End If

Next J

End With

Next F

Columns("A:E").AutoFit

End Sub

Encore merci à tous ! Et Banzai !! ^^ (cf Groland)

Très cordialement,

** Pierrot **

Rechercher des sujets similaires à "macro partir onglets concatener"