Comment regrouper des colonnes...

[fouedou77]

Bonjour à tous !

Comment est-il possible de regrouper par exemple les colonnes A, B et C de (de 10 lignes par exemple ou plus...) toutes les feuilles du classeur et les coller dans une nouvelle feuille à la fin.

Merci pour vos réponses d'avance !

 

[mat20008]

Re : Comment regrouper des colonnes...

J'y travaille en ce moment, à quelque chose près, je dois compiler un dossier qui comporte 10 onglets avec 10 à 500 lignes sur chaque onglet...
Un peu de programmation VBA, je débute mais ça peut être pratique...

As tu trouvé bonheur? Un programme, une macro...?

Cdmt

Mathieu

 

[antha]

Re : Comment regrouper des colonnes...

Bonjour,

Vous pouvez aller voir sur ce thread, cela devrait répondre à ce que vous recherchez tous les deux.

Cf. le fichier posté par MJ13

 

[CBernardT]

Re : Comment regrouper des colonnes...

Bonjour à tous,

Je prend le fil en route, mais tout de même, une petite macro qui doit faire correctement son travail.

Sub ListageDonnées()
Dim Derligne As Integer, i As Integer
' Effacement des données précédentes
With Sheets("Liste")
Derligne = .Range("A65536").End(xlUp).Row
If Derligne > 1 Then .Range("A2:C" & Derligne).ClearContents
' Report des données des feuilles
For i = 1 To Sheets.Count
If Sheets(i).Name <> "Liste" Then
Derligne = Sheets(i).Range("A65536").End(xlUp).Row
Sheets(i).Range("A2:C" & Derligne).Copy .Range("A" & .Range("A65536").End(xlUp).Row + 1)
End If
Next i
End With
End Sub


Cordialement

Bernard

 

[antha]

Re : Comment regrouper des colonnes...

Bernard,

Saurais-tu adapter cette macro pour regrouper plusieurs colonnes qui se trouvent sur une même feuille ?

A partir des colonnes A, B et C (voire plus si possible), créer une liste unique sur une autre colonne.

Merci de ton aide!

 

[CBernardT]

Re : Comment regrouper des colonnes...

Re Antha,

Place un petit exemple pour mieux cerner le problème.

De prime abord, cela ne présente pas de difficulté particulière.

Cordialement

Bernard

 

[antha]

Re : Comment regrouper des colonnes...

Voilà

La 1ère et la 3e sont à modifier par les utilisateurs. La longueur de chacune des listes peut varier.
La 2e sera fixe.

Je souhaiterai les réunir en une seule liste, pour pouvoir entre autre les utiliser ensuite en validation.

Merci !

 

[CBernardT]

Re : Comment regrouper des colonnes...

Re,

Une mise en liste triée qui j'espère correspond à ton souhait ?

Cordialement

Bernard

 

[antha]

Re : Comment regrouper des colonnes...

C'est exactement cela!

Merci beaucoup de ton aide.

 

[antha]

Re : Comment regrouper des colonnes...

Re bonjour,

Une petite demande supplémentaire en lien avec la précédente si tu as le temps d'y jeter un oeil!

J'ai essayé de modifier la macro que tu m'avais donnée, car j'aurai voulu positionner les listes à fusionner à un autre endroit. "Et là c'est le drame"...

Je n'arrive pas à modifier ces conditions vu mon niveau (je vais m'y mettre!!). La seule chose que j'ai pu faire c'est décaler la liste de sortie.

Le but serait dans le fichier joint, de fusionner les listes "Secteurs libres" et "secteurs communs". Sachant la hauteur de la 1ere est au max de 20 et la seconde est fixe à 7 éléments.
La liste secteurs de garde n'a pas besoin d'être fusionnée avec les autres.

Merci encore un fois de ton aide! (ou d'autres également )

Bonne fin de journée

 

[CBernardT]

Re : Comment regrouper des colonnes...

Bonsoir Antha et le forum,

La présentation est belle et en ce qui concerne le VBA tu es en bonne voie, très bientôt cela sera parfait !

Quelques ajustements de code est la mise en liste est opérationnelle.

Cordialement

Bernard

 

[antha]

Re : Comment regrouper des colonnes...

Merci pour ces corrections...!

J'étais justement en train de zieuter le cours de VBA indiqué dans le forum histoire de me coucher moins bête et pouvoir m'y mettre

Bonne soirée.

 

[mat20008]

Re : Comment regrouper des colonnes...

Bonjour Bernard,

Merci pour ton post, dslé du retard, j'avais pas vu la réponse...
J'ai esayé ton code, j'ai erreur d'execution 9...à la ligne:
With Sheets("")

A vrai dire, j'ai toujours pas résolu mon problème, j'ai déjà une macro qui me regroupe mes onglets, le soucis c'est que quand on fait le compte des lignes sur les 20 onglets de fichiers il y en a 1936, et en exécutant la macro, il m'en reste 1934...

Etant donnée que la liste créer sur le nouvel onglet doit me servir de base pour des rapports commerciaux, ça fait un peu tache d'oublier des infos importantes...

Qui plus est, mon dossier de base avec les 20 onglets comporte parfois des colonnes supplémentaires, si je peux regrouper par champ ça peut être plus simple?

Bref, je suis un peu dépassé par la chose, je suis pas (encore) développeur, voici la macro existante, peut tu me dire si tu vois une erreur?

Cdmt
Mathieu



Option Explicit
Const NbTypes = 3
Const NbLignesMax = 30000
Const TxtErreurFormat = "Le format du fichier source traité n'est pas celui attendu. Aucune donnée ne sera produite."
Const NbMaxColumns = 100

Const IndexRowTitle = 1
Const constIndexFirstColDst = 1

Private Sub CommandButton1_Click()
Dim memtxt As String
Dim rwIndex As Long
Dim colIndex As Long
Dim IndexWkbSrc As Long
Dim IndexWksSrc As Long
Dim IndexWkbDst As Long
Dim IndexWksDst As Long
Dim WkbSrc As Workbook
Dim WksSrc As Worksheet
Dim WkbDst As Workbook
Dim WksDst As Worksheet
Dim i As Long
Dim RowDestTxt1 As Long
Dim RowSrcTxt1 As Long
Dim RowDestTxt2 As Long
Dim RowSrcTxt2 As Long
Dim FileName As Variant
Dim NbLines As Long
Dim NameWkbTrt As String
Dim IndexFirstColSrc As Long
Dim IndexLastColSrc As Long
Dim IndexFirstColDst As Long
Dim IndexFirstColCopyDst As Long
Dim IndexFirstColCopyGrpDst As Long
Dim IndexLastColDst As Long
Dim FirstColSrc As String
Dim LastColSrc As String
Dim FirstColDst As String
Dim FirstColCopyDst As String
Dim FirstColCopyGrpDst As String
Dim LastColDst As String
Dim bColGroupe As Boolean
Dim Nom_Modele As String
Dim WkbSrcName As String
Dim bCreateWksDst As Boolean
Dim WksDstNum As Integer

NameWkbTrt = ActiveWorkbook.Name

RowDestTxt2 = 1

' Le nom du modèle qui sert à créer le WorkSheet destination
Nom_Modele = "Modele"

' La première feuille destination est la numéro 1
WksDstNum = 1

' Il faut créer une feuille destination
bCreateWksDst = True

'Ouverture du fichier Source
FileName = Application.GetOpenFilename

' Si la commande d'ouverture de fichier est annulé on arrête la procédure
If FileName = False Then
Exit Sub
End If

Application.Workbooks.Open (FileName)

' Mémorise l'index du WorkBook qu'on vient d'ouvrir
IndexWkbSrc = Application.Workbooks.Count

If IndexWkbSrc = 0 Then GoTo Exit_sub

Set WkbSrc = Application.Workbooks(IndexWkbSrc)

WkbSrcName = WkbSrc.Name

'Création du fichier destination
Application.Workbooks.Add


' Mémorise l'index du WorkBook qu'on vient d'ouvrir
IndexWkbDst = Application.Workbooks.Count

If IndexWkbDst = 0 Then GoTo Exit_sub

Set WkbDst = Application.Workbooks(IndexWkbDst)

WkbSrc.Activate

' Dans certains extracts ISIS certaines feuilles en général celle de PARIS
' contiennent une colonne supplémentaire appelée groupe
bColGroupe = False

For Each WksSrc In WkbSrc.Worksheets
If Left(Trim(WksSrc.Name), 3) <> "SSH" Then
WksSrc.Select
WksSrc.Cells.Select ' Il faut sélectionner toutes les cellules pour supprimer les S/totaux
Selection.RemoveSubtotal
End If

' Si on trouve une colonne Groupe on le mémorise
'If left(LCase(Trim(WksSrc.Range("A1").Value)),6) = LCase("Groupe") Then bColGroupe = True
Next WksSrc

Set WksSrc = WkbSrc.Worksheets(1)

For i = 1 To NbMaxColumns
If WksSrc.Cells(IndexRowTitle, i).Value = "" Then
Exit For
End If
Next i

IndexFirstColSrc = 1

If Left(LCase(Trim(WksSrc.Range("A1").Value)), 6) <> LCase("Groupe") Then
IndexLastColSrc = i
Else
IndexLastColSrc = i - 1
End If
IndexFirstColDst = constIndexFirstColDst
IndexFirstColCopyGrpDst = IndexFirstColDst + 1
IndexFirstColCopyDst = IndexFirstColDst + 2

If Left(LCase(Trim(WksSrc.Range("A1").Value)), 6) <> LCase("Groupe") Then
IndexLastColDst = IndexFirstColCopyDst + (IndexLastColSrc - IndexFirstColSrc)
Else
IndexLastColDst = IndexFirstColCopyGrpDst + (IndexLastColSrc - IndexFirstColSrc)
End If

'=SI((A2-1)/$A$1>=1;CAR(CODE("A")+(A2-1)/$A$1-1)&CAR(CODE("A")+MOD(A2-1;$A$1));CAR(CODE("A")+MOD(A2-1;$A$1)))
FirstColSrc = Chr$(Asc("A") + ((IndexFirstColSrc - 1) Mod 26))
If ((IndexFirstColSrc - 1) / 26) >= 1 Then
FirstColSrc = Chr$(Asc("A") + ((IndexFirstColSrc - 1) / 26) - 1) & FirstColSrc
End If
LastColSrc = Chr$(Asc("A") + ((IndexLastColSrc - 1) Mod 26))
If ((IndexLastColSrc - 1) / 26) >= 1 Then
LastColSrc = Chr$(Asc("A") + ((IndexLastColSrc - 1) / 26) - 1) & LastColSrc
End If
FirstColDst = Chr$(Asc("A") + ((IndexFirstColDst - 1) Mod 26))
If ((IndexFirstColDst - 1) / 26) >= 1 Then
FirstColDst = Chr$(Asc("A") + ((IndexFirstColDst - 1) / 26) - 1) & FirstColDst
End If
FirstColCopyGrpDst = Chr$(Asc("A") + ((IndexFirstColCopyGrpDst - 1) Mod 26))
If ((IndexFirstColCopyGrpDst - 1) / 26) >= 1 Then
FirstColCopyGrpDst = Chr$(Asc("A") + ((IndexFirstColCopyGrpDst - 1) / 26) - 1) & FirstColCopyGrpDst
End If
FirstColCopyDst = Chr$(Asc("A") + ((IndexFirstColCopyDst - 1) Mod 26))
If ((IndexFirstColCopyDst - 1) / 26) >= 1 Then
FirstColCopyDst = Chr$(Asc("A") + ((IndexFirstColCopyDst - 1) / 26) - 1) & FirstColCopyDst
End If
LastColDst = Chr$(Asc("A") + ((IndexLastColDst - 1) Mod 26))
If ((IndexLastColDst - 1) / 26) >= 1 Then
LastColDst = Chr$(Asc("A") + ((IndexLastColDst - 1) / 26) - 1) & LastColDst
End If

Me.Activate

' On parcoure l'ensemble des feuilles du classeur source
For Each WksSrc In WkbSrc.Worksheets
'WksSrc.Select
'Selection.RemoveSubtotal
If Left(Trim(WksSrc.Name), 3) <> "SSH" Then
'WksSrc.Select
'Selection.RemoveSubtotal
rwIndex = 2
i = 0
While (WksSrc.Cells(rwIndex + i, 1).Value <> "")
If (i > NbLignesMax) Then
GoTo Erreur
End If
i = i + 1
Wend

NbLines = i

' Si le nombre de lignes de la feuille source en cours génère un dépassement
' de la limite des 65535 lignes dans la destination, on génère une nouvelle
' feuille destination
If (RowDestTxt1 + NbLines - 1) > 65535 Then
bCreateWksDst = True
WksDstNum = WksDstNum + 1
End If

' Traitement de la création d'une feuille destination
If bCreateWksDst = True Then
' Création des feuilles dans le classeur destination
Workbooks(NameWkbTrt).Worksheets(Nom_Modele).Copy Workbooks(IndexWkbDst).Worksheets(WksDstNum)
WkbDst.Worksheets(WksDstNum).Unprotect
WkbDst.Worksheets(WksDstNum).Name = Trim(Str$(WksDstNum)) & "_" & Left(Trim(WkbSrcName), 27)
Set WksDst = WkbDst.Worksheets(WksDstNum)

'Recopie des entêtes de colonnes
If Left(LCase(Trim(WksSrc.Range("A1").Value)), 6) <> LCase("Groupe") Then
WksDst.Range(FirstColCopyDst & IndexRowTitle, LastColDst & IndexRowTitle).Value = WksSrc.Range(FirstColSrc & IndexRowTitle, LastColSrc & IndexRowTitle).Value
WksDst.Range("B1").Value = "Groupe"
Else
WksDst.Range(FirstColCopyGrpDst & IndexRowTitle, LastColDst & IndexRowTitle).Value = WksSrc.Range(FirstColSrc & IndexRowTitle, LastColSrc & IndexRowTitle).Value
End If
WksDst.Range("A1").Value = "Nom_Agence"
bCreateWksDst = False
RowDestTxt2 = 1
End If

' Copie des données sources vers la destination
' et mise à jour des index de ligne source et destination
RowDestTxt1 = RowDestTxt2 + 1
RowDestTxt2 = RowDestTxt1 + NbLines - 1
RowSrcTxt1 = rwIndex
RowSrcTxt2 = rwIndex + NbLines - 1
If Left(LCase(Trim(WksSrc.Range("A1").Value)), 6) <> LCase("Groupe") Then
WksDst.Range(FirstColCopyDst & RowDestTxt1, LastColDst & RowDestTxt2).Value = WksSrc.Range(FirstColSrc & RowSrcTxt1, LastColSrc & RowSrcTxt2).Value
WksSrc.Range(FirstColSrc & RowSrcTxt1, LastColSrc & RowSrcTxt2).Copy
WksDst.Range(FirstColCopyDst & RowDestTxt1, LastColDst & RowDestTxt2).PasteSpecial (xlPasteFormats)
Else
WksDst.Range(FirstColCopyGrpDst & RowDestTxt1, LastColDst & RowDestTxt2).Value = WksSrc.Range(FirstColSrc & RowSrcTxt1, LastColSrc & RowSrcTxt2).Value
WksSrc.Range(FirstColSrc & RowSrcTxt1, LastColSrc & RowSrcTxt2).Copy
WksDst.Range(FirstColCopyGrpDst & RowDestTxt1, LastColDst & RowDestTxt2).PasteSpecial (xlPasteFormats)
End If
WksDst.Range(FirstColDst & RowDestTxt1, FirstColDst & RowDestTxt2) = WksSrc.Name
rwIndex = rwIndex + NbLines
End If
Next WksSrc

' Ajustement des colonnes des feuilles destination
For i = 1 To WksDstNum
Set WksDst = WkbDst.Worksheets(i)
WkbDst.Activate
WksDst.Activate
WksDst.Cells.Select
WksDst.Cells.Font.Name = "Arial"
WksDst.Cells.Font.Size = 10
WksDst.Cells.EntireColumn.AutoFit
WksDst.Rows(1).Font.Bold = True
Next

Exit_sub:
WkbSrc.Close
MsgBox "Fin du traitement", vbOKOnly, "Traitement Générique"
Exit Sub

Erreur:
MsgBox TxtErreurFormat, vbOKOnly, "Traitement Générique"
WkbDst.Close
GoTo Exit_sub

End Sub