errore di runtime 4248

Hai un problema con Excel?

Nuova discussione

errore di runtime 4248
di nicola (utente non iscritto) data: 10/04/2013 16:53:05
Chiedo aiuto per capire come mai mi compare questo messaggio di errore ( quando in realtà il foglio word risulta aperto), poiché il codice allegato funziona fino al msg box (che ho utilizzato come debug), come potete notare ho provato piu' soluzioni ma senza esito.
Ho necessità di aprire qualsiasi file di word selezionato dalla finestra apri e copiarne il suo contenuto.
inoltre ho notato che quando la sub copia i dati in forma tabellare in Excel salta alcune righe sullo stesso foglio oppure li sfalza (risultano vuote e non consecutive come in realtà dovrebbe avvenire).
Ringrazio per il prezioso aiuto che Vogliate darmi.
P.s. nel codice troverete righe remmate poiché provo da solo (fino a quando e dove riesco) a risolvere la problematica.

Sub TuttaTabella1()
Application.ScreenUpdating = False
Dim mioWord As New Word.Application, mioDoc As Word.Document
Dim ultima_riga As Long
 '(*.xls; *.xlsx; *.xlsm),*.xls; *xlsx; *.xlsm", , "Selezionare il file")
  
Dim PercorsoFile As String
PercorsoFile = Application.GetOpenFilename("File Microsoft Word(*.doc; *.docx),*.doc; *.docx", , "Ricerca documenti Word")
If PercorsoFile = "Falso" Then
    Exit Sub
End If


'PercorsoFile = Application.GetOpenFilename("File Microsoft Word(*.docx),*.docx", , "Ricerca documenti Word")
'Percorso = Application.GetOpenFilename("Microsoft Word (*.doc), *.doc")
    
    
    mioWord.Visible = False
    If PercorsoFile <> "" Then
    Documents.Open Filename:=PercorsoFile, OpenAndRepair:=True
    End If
   ''''''''''''''''mioWord.Documents.Open "C:UsersNicolaDesktop	est.doc"
   'Set mioDoc = mioDoc.Activate
   MsgBox ("ok")
   'mioWord.Documents.Open
   'mioDoc.Activate
   
   Set mioDoc = mioWord.ActiveDocument
    
    mioDoc.Tables(1).Range.Copy
    
    ultima_riga = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    If ultima_riga = 1 Then ultima_riga = 0
    
    ActiveSheet.Cells(ultima_riga + 1, 1).PasteSpecial xlPasteValues
    
    [A1].CurrentRegion.Columns.AutoFit
    
    mioDoc.Close
    
    mioWord.Quit

    Set mioWord = Nothing
    
    MsgBox "Ho terminato la copia dei dati."
    Application.ScreenUpdating = True

End Sub

di Vecchio Frac data: 10/04/2013 21:00:30
A cosa corrisponde il codice di errore indicato? su che riga del codice si pianta?
Sullo sfalsamento delle righe, forse accade perchè le tabelle Word hanno righe vuote che vengono copiate integralmente.
Sarà quindi necessario un breve ciclo For che parta dal basso del foglio Excel ed elimini le righe vuote.
Oppure torni a usare il vecchio codice che avevi postato nell'altra discussione (che però faceva parecchie cose superflue).
di NICOLA (utente non iscritto) data: 11/04/2013 11:24:06
RISOLTO, GRAZIE

dati su righe non consecutive
di NICOLA (utente non iscritto) data: 11/04/2013 11:41:43
N..b. ho risolto la selezione dei file di word con la finestra apri ma
come vedi, nel file di excel che ti allego, con il codice che ti posto, mi incolla alcuni dati non consevcutivamente, bensì mi copia alcune risposte nelle righe sottostanti e questo non va bene.
io vorrei che le righe del foglio che fa da raccoglitore dei dati copiati dai file di word fossero tutte consecutive.
Ti ringrazio e ti saluto Vecchio Frac.

Sub TuttaTabella1()
Application.ScreenUpdating = False
Dim mioWord As New Word.Application, mioDoc As Word.Document
Dim ultima_riga As Long
 '(*.xls; *.xlsx; *.xlsm),*.xls; *xlsx; *.xlsm", , "Selezionare il file")
  
Dim PercorsoFile As String
PercorsoFile = Application.GetOpenFilename("File Microsoft Word(*.doc; *.docx),*.doc; *.docx", , "Ricerca documenti Word")
If PercorsoFile = "Falso" Then
    Exit Sub
End If


'PercorsoFile = Application.GetOpenFilename("File Microsoft Word(*.docx),*.docx", , "Ricerca documenti Word")
'Percorso = Application.GetOpenFilename("Microsoft Word (*.doc), *.doc")
    
    
    mioWord.Visible = False
    'Documents.Open Filename:=PercorsoFile , OpenAndRepair:=True
   'mioWord.Documents.Open "C:UsersNicolaDesktopAA.doc"
   'Set mioDoc = mioDoc.Activate
   'MsgBox ("ok")
   mioWord.Documents.Open (PercorsoFile)
   'mioDoc.Activate
   
   Set mioDoc = mioWord.ActiveDocument
    
    mioDoc.Tables(1).Range.Copy
    
    ultima_riga = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    If ultima_riga = 1 Then ultima_riga = 0
    
    ActiveSheet.Cells(ultima_riga + 1, 1).PasteSpecial xlPasteValues
    
    [A1].CurrentRegion.Columns.AutoFit
    
    mioDoc.Close
    
    mioWord.Quit

    Set mioWord = Nothing
    
    MsgBox "Ho terminato la copia dei dati."
    Application.ScreenUpdating = True

End Sub

di Vecchio Frac data: 11/04/2013 12:12:49
Penso che ci siano dei salti all'interno delle celle di tabella in Word... Secondo me è la struttura del file Word che è così, ci sono alcune righe vuote.
Copy e Paste fanno il loro lavoro bene, ma se i dati originali hanno dei ritorni a capo nelle celle, bisognerà studiare un'altra soluzione.
Riesci a postare (non tutto, ma) un pezzo del file Word da importare, almeno fino alla prima riga che si sfalsa? puoi anche cancellare tutto da Word e scrivere parole senza senso, l'importante è che venga riportata la struttura della tabella di Word con esempio del contenuto nella medesima posizione.
di nichicanta data: 11/04/2013 12:33:18
vecchio frac ti ho appena inviato il file di word cosi come lo devo acquisire in excel tramite il codice precedentemente postato.
ti saluto.

nicola
di nichicanta data: 11/04/2013 15:56:34
Vecchio frac ho provato il codice che ti posto e non mi causa l'errore che ti ho precedentemente segnalato, ma non so dove inserire il tuo codice che mi scrive nella prima riga vuota e prosegue fino alla fine della copia dei file di word.
In poche parole questo codice sottoriportato mi copia perfettamente tutta la tabella di word senza alcun problema ma io vorrei continuare con la copia degli altri file selezionati con la finestra apri (che ora va bene con il codice da te inviatomi e perfezionato da me in base alle mie esigenze e inviato nella stessa discussione).
Ti saluto.

Sub TuttaTabella()

  'COPIA SIA l' IntestazionE CHE I DATI

  Dim mioWord As New Word.Application
  
  mioWord.Visible = True

  mioWord.Documents.Open "C:Documents and Settingsx880588DesktopEB.doc"

  Dim mioDoc As Document

  Set mioDoc = mioWord.Documents(1)

  Set Tabella = mioDoc.Tables(1)

  Dim Riga As Row, Cella As Cell, Valore As String

  Dim i As Integer, j As Integer

  For Each Riga In Tabella.Rows

    i = i + 1

    For Each Cella In Riga.Cells

        j = j + 1

      Valore = Cella.Range

      Valore = Left(Valore, Len(Valore) - 2) '(2)

      If Right(Valore, 1) = "%" Then

        Valore = Left(Valore, Len(Valore) - 1)

      End If

      If IsNumeric(Valore) Then

        If InStr(1, Valore, ",") Then

          Mid(Valore, InStr(1, Valore, ",")) = "."

        End If

        Range("A1")(i, j).Value = Val(Valore)

      Else

        Range("A1")(i, j).Value = Valore

      End If

    Next

    j = 0

  Next

  ' Adatta larghezza colonne

  With Range("A1")

    Range(.Cells(1, 1), .End(xlToRight)).Columns.AutoFit

  End With

  mioDoc.Close

  mioWord.Quit

  Set mioWord = Nothing

End Sub

di Vecchio Frac data: 12/04/2013 18:04:39
Ho preso visione del file .doc.
di Vecchio Frac data: 12/04/2013 18:14:28
Penso che è come dicevo io (visto che il problema si presenta esattamente alla domanda AA00039): infatti la domanda d) risulta inserita alla riga sottostante, perchè proprio nella risposta c) del file di Word c'è un ritorno a capo nella cella.
Quindi puoi risolvere il problema prima di avviare la macro di Excel aprendo Word e facendo un "Modifica Sostituisci: --> ^p" che sta per ritorno a capo con "niente" (lascia vuoto).

Dopodichè la macro Excel funzionerà bene grazie alle istruzioni
ultima_riga = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row If ultima_riga = 1 Then ultima_riga = 0 ActiveSheet.Cells(ultima_riga + 1, 1).PasteSpecial xlPasteValues
in cui viene calcolata l'ultima riga piena di Excel e i dati successivi vengono incollati consecutivamente.

di Vecchio Frac data: 12/04/2013 18:20:32
In alternativa, all'inizio della tua Sub (che ripeto fa anche cose ridondanti che potresti tagliare), devi dire a Excel dove posizionarsi come riga "i" (io l'avevo chiamata "ultima_riga" ma è indifferente).

'nel tuo codice, prima di For Each riga aggiungi queste due righe:
    i = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    If ultima_riga = 1 Then ultima_riga = 0

   For Each riga in Tabella.Rows
'segue il resto del codice

di nichicanta data: 12/04/2013 20:48:44
Grazie Vecchio Frac, ho optato per l'inserimento delle due righe di codice prima del for each ecc.
Sto proseguendo con la realizzazione del programma in cui ho utilizzato questo codice.
Somo molto contento di averti conosciuto e di aver molto apprezzato il tuo prezioso aiuto, ci sentiremo per altre discussioni.
Ti ringrazio ancora.
P.s. posto il codice definitivo (potrebbe servire ad altri) per la copia perfetta di tabelle word in foglio di excel con inserimento dei dati in righe consecutive senz alcuna perdita di formato e di dati.

Sub TuttaTabella()

  'Copia sia l' Intestazione che i dati

  Dim mioWord As New Word.Application

  mioWord.Visible = True

  
  Dim PercorsoFile As String
PercorsoFile = Application.GetOpenFilename("File Microsoft Word(*.doc; *.docx),*.doc; *.docx", , "Ricerca documenti Word")
If PercorsoFile = "Falso" Then
    Exit Sub
End If
  
  
  
   Dim mioDoc As Document
 
  mioWord.Documents.Open (PercorsoFile)
 Set mioDoc = mioWord.ActiveDocument
 
 Set Tabella = mioDoc.Tables(1)
 
  Dim Riga As Row, Cella As Cell, Valore As String

  Dim i As Integer, j As Integer
  
   i = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    If ultima_riga = 1 Then ultima_riga = 0
      
  For Each Riga In Tabella.Rows

    i = i + 1
     'segue il resto del codice
     For Each Cella In Riga.Cells

        j = j + 1

      Valore = Cella.Range

      Valore = Left(Valore, Len(Valore) - 2) '(2)

      If Right(Valore, 1) = "%" Then

        Valore = Left(Valore, Len(Valore) - 1)

      End If

      If IsNumeric(Valore) Then

        If InStr(1, Valore, ",") Then

          Mid(Valore, InStr(1, Valore, ",")) = "."

        End If

        Range("A1")(i, j).Value = Val(Valore)

      Else

        Range("A1")(i, j).Value = Valore

      End If

    Next

    j = 0

  Next

  ' Adatta larghezza colonne

  With Range("A1")

    Range(.Cells(1, 1), .End(xlToRight)).Columns.AutoFit

  End With

  mioDoc.Close

  mioWord.Quit

  Set mioWord = Nothing

End Sub

di Vecchio Frac data: 12/04/2013 21:26:18
Sono contento anche se preferivo la soluzione più compatta ^_^
Non dimenticare mai nei tuoi codici di specificare la direttiva Option Explicit in testa a tutti i moduli e di dichiarare sempre le variabili possibilmente del tipo giusto; e infine, stilisticamente, di posizionare in testa al codice dopo la firma Sub o Function tutti i Dim, non sparpagliando le dichiarazioni nel codice: questo non incide sulla velocità di esecuzione ma rende il codice più ordinato e leggibile.

Vuoi Approfondire?