Extraction d'adresse

EstelleL

XLDnaute Nouveau
Bonjour à tous,

Je cherche à extraire des données sur Excel, je m'explique :

J'ai différents fichiers Excel, avec sur chacun, des noms, prénoms, adresse et numero de téléphone. Ces informations sont sur chaque fichier au meme endroit.

J'aimerai extraire toute ces informations dans un autre fichier Excel, pour me faire en quelque sorte un carnet d'adresse.

Est-ce possible ?

Merci par avance,

Cordialement,

ESTELLE
 

Victor21

XLDnaute Barbatruc
Bonsoir, EstelleL. Et bienvenue sur XLD

Si l'organisation de ces données le permet (ce qu'un court extrait de vos fichiers aurait permis de voir si vous aviez eu la bonne idée de le joindre), ce devrait être possible. A suivre ?

Edit : bonsoir, gosselien.
 

libellule85

XLDnaute Accro
Bonsoir à vous tous, bonsoir le forum,

EstelleL n'a pas dû lire la charte (et notamment le paragraphe 5 du demandeur) avant de poster sa demande !

5 – La possibilité de joindre des fichiers est donnée sur ce forum. Ne pas hésiter à utiliser cette fonction, tout en veillant que les données soient bidons et donc qu’aucune donnée confidentielle, nominative ne soit dans le fichier.
 

job75

XLDnaute Barbatruc
Bonsoir à tous,

C'est un plaisir de voir de jolies femmes :)

Il s'agit d'une consolidation, nombreux exemples sur XLD, un de plus :
Code:
Private Sub CommandButton1_Click() 'bouton Consolider
Dim a, chemin$, fichier
a = Array("Fichier1.xlsx", "Fichier2.xlsx", "Fichier3.xlsx") 'fichiers à consolider
chemin = ThisWorkbook.Path & "\" 'à adapter au besoin
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà ouvert
If FilterMode Then ShowAllData 'si la feuille est filtrée
Rows("2:" & Rows.Count) = "" 'RAZ
For Each fichier In a
  With Workbooks.Open(chemin & fichier).Sheets(1).UsedRange.Offset(1) '.Offset(1) si titres
    Range("A" & Rows.Count).End(xlUp)(2).Resize(.Rows.Count, .Columns.Count) = .Value
    .Parent.Parent.Close False
  End With
Next
Columns.AutoFit 'ajustement largeur
UsedRange.Sort Columns(1), xlAscending, Header:=xlYes 'tri alphabétique
With UsedRange: End With 'actualise les barres de défilement
End Sub

Télécharger les 4 fichiers dans le même dossier (le bureau).

Puis cliquer sur le bouton du fichier Consolidation.

Bonne fin de soirée.
 

Pièces jointes

  • Consolidation(1).xlsm
    26.2 KB · Affichages: 23
  • Fichier1.xlsx
    14.6 KB · Affichages: 32
  • Fichier2.xlsx
    14.3 KB · Affichages: 27
  • Fichier3.xlsx
    14.2 KB · Affichages: 34
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Si les tableaux peuvent être des tableaux Excel il suffit de les convertir en plage.

Edit : non c'est inutile, ce fichier (2) est identique au fichier (1).

Bonne nuit.
 

Pièces jointes

  • Consolidation(2).xlsm
    27.9 KB · Affichages: 32
  • Fichier1.xlsx
    15.9 KB · Affichages: 37
  • Fichier2.xlsx
    15.7 KB · Affichages: 30
  • Fichier3.xlsx
    15.5 KB · Affichages: 32
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour le fil, le forum,

Si l'on veut pouvoir organiser les résultats en tableau Excel :
Code:
Private Sub CommandButton1_Click() 'bouton Consolider
Dim a, chemin$, LO As Boolean, TS$, fichier
a = Array("Fichier1.xlsx", "Fichier2.xlsx", "Fichier3.xlsx") 'fichiers à consolider
chemin = ThisWorkbook.Path & "\" 'à adapter au besoin
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier est déjà ouvert
If FilterMode Then ShowAllData 'si la feuille est filtrée
If ListObjects.Count Then LO = True: TS = ListObjects(1).TableStyle: ListObjects(1).Unlist 'si tableau Excel
Rows("2:" & Rows.Count).Delete 'RAZ
For Each fichier In a
  With Workbooks.Open(chemin & fichier).Sheets(1).UsedRange.Offset(1) '.Offset(1) si titres
    Range("A" & Rows.Count).End(xlUp)(2).Resize(.Rows.Count, .Columns.Count) = .Value
    .Parent.Parent.Close False
  End With
Next
UsedRange.Sort Columns(1), xlAscending, Header:=xlYes 'tri alphabétique
If LO Then ListObjects.Add(xlSrcRange, [A1].CurrentRegion, , xlYes).Name = "Tableau1": ListObjects(1).TableStyle = TS
Columns.AutoFit 'ajustement largeur
With UsedRange: End With 'actualise les barres de défilement
End Sub
Edit : j'ai simplifié les 3 macros.

Fichier (3).

Bon week-end.
 

Pièces jointes

  • Consolidation(3).xlsm
    30.3 KB · Affichages: 29
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour chère libellule :)

Ce n'est pas vraiment la recherche de la perfection mais le désir de supprimer les codes inutiles.

Je m'aperçois d'ailleurs qu'avec mes dernières modifications la ligne :
Code:
    If .Parent.ListObjects.Count Then .Parent.ListObjects(1).Unlist 'conversion en plage
est devenue inutile dans les fichiers (2) et (3).

Edit : comme j'aime bien les choses propres je viens de modifier les posts #6 et #7.

A+
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour à tous et à toutes,

Une solution qui utilise des formules de liaison :
Code:
Private Sub CommandButton1_Click() 'bouton Consolider
Dim a, chemin$, feuil$, ncol%, LO As Boolean, TS$, fichier, f$, h As Variant
a = Array("Fichier1.xlsx", "Fichier2.xlsx", "Fichier3.xlsx") 'fichiers à consolider
chemin = ThisWorkbook.Path & "\" 'à adapter au besoin
feuil = "Feuil1" 'nom des feuilles sources, à adapter
ncol = 4 'nombre de colonnes à copier, à adapter au besoin
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
If ListObjects.Count Then LO = True: TS = ListObjects(1).TableStyle: ListObjects(1).Unlist 'si tableau Excel
Rows("2:" & Rows.Count).Delete 'RAZ
For Each fichier In a
  f = "'" & chemin & "[" & fichier & "]" & feuil & "'!"
  h = ExecuteExcel4Macro("MATCH(""zzz""," & f & "C1)")
  If IsNumeric(h) Then
    With Range("A" & Rows.Count).End(xlUp)(2).Resize(h, ncol)
      .FormulaArray = "=" & f & "R1C1:R" & h & "C" & ncol
      .Value = .Value 'supprime la formule matricielle
      .Replace 0, "", xlWhole 'cellules vides
      .Rows(1).EntireRow.Delete 'supprime les titres
    End With
  End If
Next
UsedRange.Sort Columns(1), xlAscending, Header:=xlYes 'tri alphabétique
If LO Then ListObjects.Add(xlSrcRange, [A1].CurrentRegion, , xlYes).Name = "Tableau1": ListObjects(1).TableStyle = TS
Columns.AutoFit 'ajustement largeur
With UsedRange: End With 'actualise les barres de défilement
End Sub
Les feuilles sources doivent avoir le même nom et tous les tableaux doivent commencer en A1.

Fichiers joints.

L'exécution est plus rapide => 0,23 s contre 1,6 s avec les fichiers précédents.

Edit : avec 3 tableaux sources de 10 000 lignes => 3,4 s, post #7 => 3,5 s, post #6 => 2,6 s.

En effet ici les fichiers sources ne sont pas ouverts.

Bonne journée.
 

Pièces jointes

  • Consolidation par liaisons(1).xlsm
    29.7 KB · Affichages: 23
  • Fichier1.xlsx
    16 KB · Affichages: 25
  • Fichier2.xlsx
    15.7 KB · Affichages: 30
  • Fichier3.xlsx
    15.6 KB · Affichages: 28
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Voyons pour terminer la question des doublons.

Trier d'abord le tableau sur les noms en colonne A, puis utiliser cette macro :
Code:
Sub DoublonSuivant()
'raccourci clavier Ctrl+d
'recherche le 1er doublon en colonne A sous la cellule active
Dim c As Range, i&
Set c = Cells(ActiveCell.Row, 1)
i = 2
While LCase(c(i)) <> LCase(c(i - 1)): i = i + 1: Wend
c(i).Select
End Sub
Ainsi on fait ce qu'on veut : conserver ou supprimer le doublon.

On ne s'appuie pas sur le prénom car celui-ci peut être incomplet ou manquant.

A+
 

Discussions similaires

Réponses
26
Affichages
3 K
Réponses
2
Affichages
613