Extraction de donnée excel, au secours!!
Fermé
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
-
4 août 2008 à 15:00
mat20008 Messages postés 39 Date d'inscription mercredi 30 juillet 2008 Statut Membre Dernière intervention 29 octobre 2008 - 8 août 2008 à 14:49
mat20008 Messages postés 39 Date d'inscription mercredi 30 juillet 2008 Statut Membre Dernière intervention 29 octobre 2008 - 8 août 2008 à 14:49
A voir également:
- Extraction de donnée excel, au secours!!
- Liste déroulante excel - Guide
- Formule excel - Guide
- Si et excel - Guide
- Aller à la ligne excel - Guide
- Mise en forme conditionnelle excel - Guide
18 réponses
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
4 août 2008 à 15:03
4 août 2008 à 15:03
Salut,
Je comprend pas trop ton problème car tu as l'air d'être callé sous excel. Qu'as tu essayé comme macro?
Je comprend pas trop ton problème car tu as l'air d'être callé sous excel. Qu'as tu essayé comme macro?
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
4 août 2008 à 15:25
4 août 2008 à 15:25
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
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
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
4 août 2008 à 16:01
4 août 2008 à 16:01
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
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
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
4 août 2008 à 16:03
4 août 2008 à 16:03
j'ai pas mis ta macro création automatique de feuille/classeur ainsi que t'es messages d'erreur auto :D
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
4 août 2008 à 16:19
4 août 2008 à 16:19
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
Tu ne connais pas une appli qui fait se travail à tout hazard?
Je teste le code et je te dis quoi!
Mathieu
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
4 août 2008 à 16:25
4 août 2008 à 16:25
non je connais pas beaucoup d'application vusial basic, ce dernier n'est pas aimé par les programmateurs (on se demande bien pourquoi :D)
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
4 août 2008 à 16:42
4 août 2008 à 16:42
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
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
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
4 août 2008 à 17:03
4 août 2008 à 17:03
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
Cdmt
Mathieu
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
4 août 2008 à 17:09
4 août 2008 à 17:09
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
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
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
4 août 2008 à 17:21
4 août 2008 à 17:21
Merci pour l'indication, juste un dernier détail, à quelle ligne dois je coller le dernier code?
Merci
Mathieu
Merci
Mathieu
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
4 août 2008 à 17:25
4 août 2008 à 17:25
*En sachant que sur chaque onglet le nombre de ligne est variable de 10 à 500 lignes, et réactualisé tous les mois...:p
Cdmt
Cdmt
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
4 août 2008 à 17:36
4 août 2008 à 17:36
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
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
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
4 août 2008 à 17:41
4 août 2008 à 17:41
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
Sinon faudra rajouté un morceau en disant de ne prendre que les valeur booleene
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
5 août 2008 à 09:41
5 août 2008 à 09:41
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
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
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
5 août 2008 à 10:13
5 août 2008 à 10:13
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
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
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
5 août 2008 à 10:15
5 août 2008 à 10:15
Merci, passe moi ton mail je t'envoi ça
Mathieu
Mathieu
alkel
Messages postés
87
Date d'inscription
vendredi 16 mai 2008
Statut
Membre
Dernière intervention
5 août 2008
14
5 août 2008 à 10:16
5 août 2008 à 10:16
ok alkelalkel@yahoo.fr je te donne la réponse vers midi je dois sortir la
mat20008
Messages postés
39
Date d'inscription
mercredi 30 juillet 2008
Statut
Membre
Dernière intervention
29 octobre 2008
16
8 août 2008 à 14:49
8 août 2008 à 14:49
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
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
