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