Base de données - Optimisation

bobylaroche

XLDnaute Occasionnel
Bonjour à tous,

J'ai réalisé une petite base de données et je souhaiterai y porter une modification pour optimiser la vitesse d'importation. Une explication s'impose.

Dans un même dossier figure un classeur "BD" (base de données) et un certain nombre de classeurs sources.
En cliquant sur le bouton "Importation" du classeur BD, j'importe une plage de la feuille "DAT" figurant dans chacun des classeurs sources.

Cela fonctionne mais l'importation rame lorsque la BD devient conséquente.
La cause, c'est l'importation et l'ajout d'une ligne par le dessus, ce qui oblige à décaler vers le bas le bloc de données existant.

La solution serait d'ajouter chaque nouvelle importation à la dernière ligne+1 mais je n'y parviens pas.

Si l'une ou l'un d'entre vous a une solution, merci ;)

Pour une meilleure compréhension, 3 fichiers sources et le fichier BD en pièce jointe.
 

Pièces jointes

  • BD.xlsm
    1.6 MB · Affichages: 33
  • 1.xlsx
    15.4 KB · Affichages: 26
  • 2.xlsx
    15.4 KB · Affichages: 23
  • 3.xlsx
    15.4 KB · Affichages: 22

Lone-wolf

XLDnaute Barbatruc
Bonjour bobylaroche

Si tu veux copier à la suite c'est :
Wb.Sheets("DAT").Range("AY34:Jx34").Copy Range("b" & Rows.Count).End(xlUP)(2)


À remplacer par celle que tu as faite.
VB:
Sub Nouvellecourse1()
Dim ShD As Worksheet, ShI As Worksheet

    Set ShD = Sheets("DATA"): Set ShI = Sheets("IMPORT")
    Application.WindowState = xlMaximized

    ShD.Rows("5:5").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    ShI.Range("b5:hx5").Copy
    ShD.Range("b5").PasteSpecial xlPasteValues
    Application.CutCopyMode = 0
    Application.Goto ShI.Range("a1")
End Sub
 
Dernière édition:

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour le fil, bonjour le forum,

Je n'ai pas compris l'intérêt de l'onglet Import !?... Je ferai plutôt comme ça :

VB:
Sub macro1()
Dim CD As Workbook 'déclare la variabe CD (Classeur Destination)
Dim CA As String 'déclare la variabe CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variabe CS (Classeur Source)
Dim OD As Worksheet 'déclare la variabe OD (Onglet Destination)
Dim OS As Worksheet 'déclare la variabe OD (Onglet Source)
Dim DEST As Range 'déclare la variabe DEST (cellule de DESTination)
Dim F As String 'déclare la variabe F (Fichier)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Application.DisplayAlerts = False 'masque les messages d'Excel
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("DATA") 'défint l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier ficher .xlsx du dossier du chemin d'accès CA
Do While F <> "" 'boucle tant qu'il existe des fichiers
    Workbooks.Open CA & F 'ouvre le fichier F
    Set CS = ActiveWorkbook 'définit le classeur source CS
    Set OS = CS.Worksheets("DAT") 'définit l'onglet source CS
    'définit la cellule de destiantion DEST (B5 si B5 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD
    If OD.Range("B5").Value = "" Then Set DEST = OD.Range("B5") Else Set DEST = OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)
    OS.Range("AY34:JX34").Copy 'copy la plage AY34:JX34 de l'onglet source OS
    DEST.PasteSpecial (xlPasteValues) 'colle les valeur dans DEST
    DEST.PasteSpecial (xlPasteFormats) 'colle les formats dans DEST
    CS.Close False 'ferme le classeur source sans enregistrer
    F = Dir 'définit le prochain classeur .xlsx du dossier du chemin d'accès CA
Loop 'boucle
Application.DisplayAlerts = True 'affiche les messages d'Excel
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
 

bobylaroche

XLDnaute Occasionnel
Bonjour bobylaroche

Si tu veux copier à la suite c'est :
Wb.Sheets("DAT").Range("AY34:Jx34").Copy Range("b" & Rows.Count).End(xlUP)(2)


À remplacer par celle que tu as faite.
VB:
Sub Nouvellecourse1()
Dim ShD As Worksheet, ShI As Worksheet

    Set ShD = Sheets("DATA"): Set ShI = Sheets("IMPORT")
    Application.WindowState = xlMaximized

    ShD.Rows("5:5").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    ShI.Range("b5:hx5").Copy
    ShD.Range("b5").PasteSpecial xlPasteValues
    Application.CutCopyMode = 0
    Application.Goto ShI.Range("a1")
End Sub






Bonjour et merci Lone-wolf :)

Merci bien pour les solutions proposées, c'est sympa :)
Vu ma tendance bidouilleur, j'ai quelques soucis pour effectuer les modifications :(

Si je remplace la sub par celle proposée, rien ne change, la dernière importation s'effectue en première ligne et pas en dernière.
Si je remplace la ligne de code proposée et la sub, ça bug sur Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False

Bloup, bloup, comprends pas !
 

bobylaroche

XLDnaute Occasionnel
Bonjour le fil, bonjour le forum,

Je n'ai pas compris l'intérêt de l'onglet Import !?... Je ferai plutôt comme ça :

VB:
Sub macro1()
Dim CD As Workbook 'déclare la variabe CD (Classeur Destination)
Dim CA As String 'déclare la variabe CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variabe CS (Classeur Source)
Dim OD As Worksheet 'déclare la variabe OD (Onglet Destination)
Dim OS As Worksheet 'déclare la variabe OD (Onglet Source)
Dim DEST As Range 'déclare la variabe DEST (cellule de DESTination)
Dim F As String 'déclare la variabe F (Fichier)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Application.DisplayAlerts = False 'masque les messages d'Excel
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("DATA") 'défint l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier ficher .xlsx du dossier du chemin d'accès CA
Do While F <> "" 'boucle tant qu'il existe des fichiers
    Workbooks.Open CA & F 'ouvre le fichier F
    Set CS = ActiveWorkbook 'définit le classeur source CS
    Set OS = CS.Worksheets("DAT") 'définit l'onglet source CS
    'définit la cellule de destiantion DEST (B5 si B5 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD
    If OD.Range("B5").Value = "" Then Set DEST = OD.Range("B5") Else Set DEST = OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)
    OS.Range("AY34:JX34").Copy 'copy la plage AY34:JX34 de l'onglet source OS
    DEST.PasteSpecial (xlPasteValues) 'colle les valeur dans DEST
    DEST.PasteSpecial (xlPasteFormats) 'colle les formats dans DEST
    CS.Close False 'ferme le classeur source sans enregistrer
    F = Dir 'définit le prochain classeur .xlsx du dossier du chemin d'accès CA
Loop 'boucle
Application.DisplayAlerts = True 'affiche les messages d'Excel
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub








Bonjour et merci bien Robert,

Je galère, j'ai remplacer mama cro ;) par celle proposée mais elle ne s'éxecute pas, rien ne se passe !

Tu as raison, l'importation aurait pu se faire directement depuis l'onglet DATA mais je suis parti d'un fichier basic sans importation en lot et je l'ai bidouillé. C'est pour cette raison que la plage est collée une première fois en feuille import.

En bref, je nage.
 

bobylaroche

XLDnaute Occasionnel
Merci Robert pour ton aide, c'est gentil.

J'ai toujours une erreur et je viens d'en comprendre l'origine sans en connaitre la raison.

C'est une bourde de ma part, ton classeur fonctionne super bien avec les 3 classeurs sources fournis enregistrés au format xlsx.
Ceux que j'utilise sont en fait au format xlsm car ils comportent des macros.

J'ai donc remplaçé "F = Dir(CA & "*.xlsx")" par "F = Dir(CA & "*.xlsm") mais rien n'y fait.

En résumé, le classeur fonctionne pour les classeurs sources exemples au format xlsx mais aucune importation ou plantage d'excel pour le format xlsm ! C'est du Chinois.
 

Robert

XLDnaute Barbatruc
Repose en paix
Re,

Essaie comme ça :

VB:
Sub macro1()
Dim CD As Workbook 'déclare la variabe CD (Classeur Destination)
Dim CA As String 'déclare la variabe CA (Chemin d'Accès)
Dim CS As Workbook 'déclare la variabe CS (Classeur Source)
Dim OD As Worksheet 'déclare la variabe OD (Onglet Destination)
Dim OS As Worksheet 'déclare la variabe OD (Onglet Source)
Dim DEST As Range 'déclare la variabe DEST (cellule de DESTination)
Dim F As String 'déclare la variabe F (Fichier)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Application.DisplayAlerts = False 'masque les messages d'Excel
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Worksheets("DATA") 'défint l'onglet destination OD
CA = CD.Path & "\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xls*") 'définit le premier ficher .xls* du dossier du chemin d'accès CA
Do While F <> "" 'boucle tant qu'il existe des fichiers
    If F <> CD.Name Then 'condition : si F est différent du nom du fichier actuel
        Workbooks.Open CA & F 'ouvre le fichier F
        Set CS = ActiveWorkbook 'définit le classeur source CS
        Set OS = CS.Worksheets("DAT") 'définit l'onglet source CS
        'définit la cellule de destiantion DEST (B5 si B5 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD
        If OD.Range("B5").Value = "" Then Set DEST = OD.Range("B5") Else Set DEST = OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)
        OS.Range("AY34:JX34").Copy 'copy la plage AY34:JX34 de l'onglet source OS
        DEST.PasteSpecial (xlPasteValues) 'colle les valeur dans DEST
        DEST.PasteSpecial (xlPasteFormats) 'colle les formats dans DEST
        CS.Close False 'ferme le classeur source sans enregistrer
    End If 'fin de la condition
    F = Dir 'définit le prochain classeur .xls* du dossier du chemin d'accès CA
Loop 'boucle
Application.DisplayAlerts = True 'affiche les messages d'Excel
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
 

Discussions similaires

Réponses
6
Affichages
277