Extraction de donnée excel, au secours!!

Salut,

Je comprend pas trop ton problème car tu as l'air d'être callé sous excel. Qu'as tu essayé comme macro?

Merci de ta réponse,

A vrai dire, j'ai déjà une macro qui me permet d'extraire les données d'une dizaine d'onglet, pour les regrouper ensuite sur une seule feuille.

Le soucis, c'est que cette macro à la facheuse tendance à oublier une ou deux lignes....quand on parle de résultat commerciaux ça peut devenir galère...

Bref, je cherche soit un outil qui fonctionne pour faire l'extraction de données de plusieurs onglets sur un seul, soit avoir comprendre la macro et la corriger, la voici...:
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 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

ok comme je connais pas à fond tes feuilles j'ai du mal à voir ta maccro.

Après quelque recherche sur un forum excel (ou tu pourra demander leur aide) j'ai trouvé quelque début de discution intéressante concernant l'automatisation de la copie de feuille en feuille

https://www.excel-downloads.com/threads/vba-importer-contenu-dune-feuille.97341/

si on suit leur raisonnement cela devrai donner

Sub test()

Workbooks.Open Filename:= _
"C:\Documents and Settings\mutthe\Mes documents\Classeur1.xls"
' ouvre "Classeur1"
Range("A1-15").Select ' sélectionne toutes les données non vides de ce classeur
Selection.Copy cette partie est à modifier pour ne prendre que ta ligne
Windows("Classeur2.xls").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

et tu continue pour tes dix feuilles etc etc
End Sub

j'ai pas mis ta macro création automatique de feuille/classeur ainsi que t'es messages d'erreur auto :D

Merci pour le code, je vais tester avec mes quelques compétences en vba...presque nulle:)

Tu ne connais pas une appli qui fait se travail à tout hazard?

Je teste le code et je te dis quoi!

Mathieu

non je connais pas beaucoup d'application vusial basic, ce dernier n'est pas aimé par les programmateurs (on se demande bien pourquoi :D)

Après le test du dernier code sur le lien que tu m'as envoyé, je suis sur la bonne voie mais il me manque encore quelques précision.

La macro executée me demande bien d'ouvire le fichier concerné, ok parfait, il me colle des données issues du fichier...là presque ok à part que j'ai besoin qu'il ouvre toutes les feuilles et les compile sur une seule...là je bug un peu...
Je ne sais pas ou coller ton code ci dessus, et à quel moment nommer chaque feuille à compiler pour l'inclure dans le code.

On dira que j'ai besoin des colonnes A à AE dans les feuilles Paris, Lille, Strasbourg, Bordeaux...
Comment dois je écrire cela?
Cdmt

PS: voici ce qui a déjà été inscrit comme code:
Sub test()
Dim a As Variant, Nom As String

Nom = ActiveWorkbook.Name
ChDrive "C:" ' Choix du lecteur
ChDir "C:\" 'Choix du répertoire
a = Application.GetOpenFilename("fichier excel (*.xls), *.xls", _
, "Sélection de vos fichiers excel", , True)

Select Case TypeName(a)
Case Is = "Boolean"
Exit Sub
Case Else
For b = LBound(a) To UBound(a)
Workbooks.Open a(b)
Next
End Select

Nom2 = ActiveWorkbook.Name
Cells.Select
Selection.Copy
Windows(Nom).Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.DisplayAlerts = False
Windows(Nom2).Close
Application.DisplayAlerts = True

End Sub

Je précise aussi que tous les onglets sont dans la meme feuille, le but étant d'avoir un onglet unique listant l'ensemble du contenu des onglets "ville"
Cdmt

Mathieu

essaie ce code:
Sheets("paris").Range("A1:A10").Value = _
Sheets("Compilation").Range("A1:A10").Value
Sheets("Lille").Range("B1:B10").Value = _
Sheets("Compilation").Range("B1:C10").Value
Sheets("Bordeaux").Range("C1:C10").Value = _
Sheets("Feuil2").Range("C1:C10").Value
etc etc

Value veux dire qu'il prendra les valeurs seulements et pas tes formules mathématiques

Merci pour l'indication, juste un dernier détail, à quelle ligne dois je coller le dernier code?

Merci

Mathieu

*En sachant que sur chaque onglet le nombre de ligne est variable de 10 à 500 lignes, et réactualisé tous les mois...:p

Cdmt

Sub test()
Dim a As Variant, Nom As String

Nom = ActiveWorkbook.Name
ChDrive "C:" ' Choix du lecteur
ChDir "C:\" 'Choix du répertoire
a = Application.GetOpenFilename("fichier excel (*.xls), *.xls", _
, "Sélection de vos fichiers excel", , True)

Sheets("paris").Range("A1:A10").Value = _
Sheets("Compilation").Range("A1:A10").Value

Sheets("Lille").Range("B1:B10").Value = _
Sheets("Compilation").Range("B1:C10").Value

Sheets("Bordeaux").Range("C1:C10").Value = _
Sheets("Feuil2").Range("C1:C10").Value

End Sub

bon après tu peux simplifier (ou pas) la chose en fesant une redondance genre pour paris i=1, lille i=2, ... et avec ça tu peux modifier les range mais je pense que ca allonge le code plus qu'autre chose

alors dans les range tu met de 1 à 500 mais je sais pas s'il va te mettre en valeur 0 diése ou rien. Normalement si c'est rien c'est bon :p
Sinon faudra rajouté un morceau en disant de ne prendre que les valeur booleene

Salut,

Merci pour ta réponse, effectivement petit soucis, j'ai une erreur d'execution 9, VB me souligne en jaune les lignes concernant les villes...
Je comprend pas trop les valeurs boléennes, les i=Paris.....je calle...
Après dans ton code, j'ai pas non plus compris pourquoi tu mets dans range(A1:A10), B1:C10...je comprend pas trop la logique, voici ce que j'ai incrit à ces lignes:
Sub test()
Dim a As Variant, Nom As String

Nom = ActiveWorkbook.Name
ChDrive "C:" ' Choix du lecteur
ChDir "C:\" 'Choix du répertoire
a = Application.GetOpenFilename("fichier excel (*.xls), *.xls", _
, "Sélection de vos fichiers excel", , True)

Sheets("agence PARIS - I.D.F.").Range("A1:A10").Value = _
Sheets("Compilation").Range("A1:A10").Value

Sheets("LILLE").Range("A1:AE500").Value = _
Sheets("Compilation").Range("A1:AE500").Value

Sheets("CAEN").Range("A1:AE500").Value = _
Sheets("Compilation").Range("A1:AE500").Value

Select Case TypeName(a)
Case Is = "Boolean"
Exit Sub
Case Else
For b = LBound(a) To UBound(a)
Workbooks.Open a(b)
Next
End Select

Cdmt

Mathieu

as tu créés l'onglet compilation? t'es valeurs de range vont pas
tu copie de a1 à a10 ton onglet paris mais tu écrase avec les autres villes

j'aurais plutôt vu un truc comme ça
Sheets("LILLE").Range("A1:AE500").Value = _
Sheets("Compilation").Range("B1:BE500").Value

Sheets("CAEN").Range("A1:AE500").Value = _
Sheets("Compilation").Range("C1:Cj'aurais pluto vu comme çaE500").Value

Aurais tu un vieux classeur excel à envoyer avec les noms précis de t'es onglets (?

courage

Merci, passe moi ton mail je t'envoi ça

Mathieu

ok alkelalkel@yahoo.fr je te donne la réponse vers midi je dois sortir la

Salut, j'ai trouvé une macro qui fait ce que je cherche, ça fonctionne nickel, juste quelques détails restant à trouver pour la gestion des colonnes en trop...

Cdmt

Mathieu

Voici la macro pour ceux que ça intéresse:

Sub cumul()
'
' cumul Macro par Mj pour https://www.excel-downloads.com/threads/creer-une-liste-a-partir-de-plusieurs-feuilles.85411/
'

'
'Stop
For i = 1 To ActiveWorkbook.Worksheets.Count - 1

Sheets(i).Select
derligne = ActiveSheet.Range("A65536").End(xlUp).Row
Range("A2:AE" & derligne).Select
Selection.Copy
Sheets(ActiveWorkbook.Worksheets.Count).Select
Range("A" & Range("a65536").End(xlUp).Row + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Next i
End Sub