Erreur d'exécution 7 : Mémoire insuffisante...

[jbballeyguier]

Bonjour,

j'ai une macro qui me sert à importer des données depuis un tableau word vers une feuille excel (oui ça peut paraître bizarre mais bon...). J'ai environ 500 documents word à ouvrir pour reporter les données vers ma feuille excel.

La macro marche pas trop mal, mais au bout de la 130e fiche, il m'envoie une erreur d'exécution 7 me disant que la mémoire est insuffisante.

Je me demandais s'il y avait un moyen d'optimiser ma macro pour qu'elle s'exécute jusqu'au bout.
J'ai pensé purger des variables (MaVariable = Nothing), mais je ne sais pas si ce sera d'une grande utilité.

Par ailleurs, lorsque je récupère les données dans les cellules Excel, il me remplace certains espaces par des petits carrés blancs : peut-être un problème d'encodage... Y a t'il un moyen d'éviter cette corruption ?

Voici la macro en question :

Sub fiches()
    Dim ObjWord As New Word.Application
    Set ObjWord = CreateObject("Word.Application")
    
    Dim PardeRef, TitdeRef, Prealable, Cas, ResAttendu As String
    
    h = 2
    
    ThisWorkbook.Sheets("racines").Activate

    For I = 2 To 600
        If Cells(I, 1) <> "" Then
        Cells(I, 1).Select
        Fiche = ActiveCell.Value
        
        Application.DisplayAlerts = False
        ObjWord.ShowMe
        ObjWord.Visible = True
        ObjWord.Documents.Open Filename:=Fiche
        Fiche = CStr(Fiche)
        Fiche = Mid(Fiche, InStrRev(Fiche, "\") + 1)
        
        ObjWord.Documents(Fiche).Activate
        Set MaFiche = ObjWord.ActiveDocument
        
        PardeRef = MaFiche.Tables(1).Cell(2, 2).Range.Text
        TitdeRef = MaFiche.Tables(1).Cell(3, 2).Range.Text
        Prealable = MaFiche.Tables(4).Cell(2, 2).Range.Text
        Cas = MaFiche.Tables(4).Cell(3, 2).Range.Text
        ResAttendu = MaFiche.Tables(4).Cell(4, 2).Range.Text
        
            ThisWorkbook.Sheets("Table_cdp").Cells(h, 1).Value = PardeRef
            ThisWorkbook.Sheets("Table_cdp").Cells(h, 2).Value = TitdeRef
            ThisWorkbook.Sheets("Table_cdp").Cells(h, 3).Value = Prealable
            ThisWorkbook.Sheets("Table_cdp").Cells(h, 4).Value = Cas
            ThisWorkbook.Sheets("Table_cdp").Cells(h, 5).Value = ResAttendu
            
            MaFiche.Close
            
            h = h + 1
        End If
    Next

End Sub

Merci d'avance pour votre aide

 

[Roland_M]

Re : Erreur d'exécution 7 : Mémoire insuffisante...

bonsoir

essai comme ceci !?
en tous les cas ça devrait être beaucoup plus rapide !
-Application.Calculation = xlCalculationManual
-Application.ScreenUpdating = False
-les .Select sont inutiles et font perdre du temps
voir la remarque avec Activate

Sub Fiches()
' attention ThisWorkbook est Activate avant la boucle (******) !?
' puis dans la boucle ObjWord.Documents(Fiche) est à son tour Activate '(******)
' sans remettre ThisWorkbook Activate ! il y un risque risque à la lecture de .Cells(Lig, 1)
Dim Lig As Integer, LigTabl As Integer
Dim ObjWord As New Word.Application
Set ObjWord = CreateObject("Word.Application")
ThisWorkbook.Sheets("racines").Activate '(******)
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LigTabl = 2
For Lig = 2 To 600
 If ThisWorkbook.Sheets("racines").Cells(Lig, 1) <> "" Then
    Fiche = ThisWorkbook.Sheets("racines").Cells(Lig, 1).Value
    ObjWord.ShowMe
    ObjWord.Visible = True
    ObjWord.Documents.Open Filename:=Fiche
    Fiche = CStr(Fiche)
    Fiche = Mid(Fiche, InStrRev(Fiche, "\") + 1)
    ObjWord.Documents(Fiche).Activate '(******)
    Set MaFiche = ObjWord.ActiveDocument
    With ThisWorkbook.Sheets("Table_cdp")
     .Cells(LigTabl, 1).Value = MaFiche.Tables(1).Cell(2, 2).Range.Text 'PardeRef
     .Cells(LigTabl, 2).Value = MaFiche.Tables(1).Cell(3, 2).Range.Text 'TitdeRef
     .Cells(LigTabl, 3).Value = MaFiche.Tables(4).Cell(2, 2).Range.Text 'Prealable
     .Cells(LigTabl, 4).Value = MaFiche.Tables(4).Cell(3, 2).Range.Text 'Cas
     .Cells(LigTabl, 5).Value = MaFiche.Tables(4).Cell(4, 2).Range.Text ' ResAttendu
    End With
    MaFiche.Close
    LigTabl = LigTabl + 1
 End If
Next
ThisWorkbook.Sheets("racines").Activate
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set ObjWord = Nothing
End Sub

EDIT : ta question
Par ailleurs, lorsque je récupère les données dans les cellules Excel, il me remplace certains espaces par des petits carrés blancs : peut-être un problème d'encodage... Y a t'il un moyen d'éviter cette corruption ?

il faudrait savoir qui est texte et qui est numérique
car je vois tout en Range().Texte !? c'est puet être de là que ça vient !?

 

[Catrice]

Re : Erreur d'exécution 7 : Mémoire insuffisante...

Bonjour,

Je propose cette version (testée sur 521 fichiers => pas de plantage) :
Cette version enlève les petits carrés.

Sub Fiches()
Application.StatusBar = "Traitement en cours ..."
ThisWorkbook.Sheets("Table_cdp").Cells.Clear
Set ObjWord = CreateObject("Word.Application")
Set fs = CreateObject("Scripting.FileSystemObject")
h = 2
Var1 = Application.CountA(ThisWorkbook.Sheets("racines").Columns(1))
With ThisWorkbook.Sheets("racines")
For Each X In .Range("A2:" & .Range("A65536").End(xlUp).Address)
Application.StatusBar = Format(j / Var1, "0%")
j = j + 1
If X <> "" Then
ObjWord.Visible = False
If fs.FileExists(X.Value) Then
ObjWord.Documents.Open Filename:=X.Value
Set MaFiche = ObjWord.Documents(Mid(X.Value, InStrRev(X.Value, "\") + 1))
With ThisWorkbook.Sheets("Table_cdp")
If MaFiche.Tables.Count > 0 Then 'Test le nb de tableaux dans le fichier Word
.Cells(h, 1).Value = MaFiche.Tables(1).Cell(2, 2).Range.Text 'PardeRef
.Cells(h, 2) = MaFiche.Tables(1).Cell(3, 2).Range.Text 'TitdeRef
End If
If MaFiche.Tables.Count > 3 Then
.Cells(h, 3) = MaFiche.Tables(4).Cell(2, 2).Range.Text 'Prealable
.Cells(h, 4) = MaFiche.Tables(4).Cell(3, 2).Range.Text 'Cas
.Cells(h, 5) = MaFiche.Tables(4).Cell(4, 2).Range.Text 'ResAttendu
End If
End With
MaFiche.Close False
h = h + 1
End If
End If
Next
End With
Application.StatusBar = "Fin du traitement ..."
ObjWord.Quit
Set ObjWord = Nothing
Set fs = Nothing
With ThisWorkbook.Sheets("Table_cdp").Cells
.Replace What:=Chr(7), Replacement:=""
.Replace What:=Chr(13), Replacement:=" "
End With
Application.StatusBar = False
End Sub

Voir le fichier joint.