problema strano

Hai un problema con Excel?

Nuova discussione

problema strano
di gio (utente non iscritto) data: 08/10/2012 11:46:17
mi succede un problema strano

quando apro una macro che, dopo aver selezionato una cartella, in automatico importa e elabora tutti i file che contiene...se la cartella contiene ad esempio 4 file spesso e volentieri [ma non sempre] la prima volta ne carica 6 [ovviamente 2 doppi]..solo rieseguendo 1 o 2 volte la stessa macro [senza modificare neinte] mi carica 4 file e li elabora correttamtne..
la macro è questa...

Sub auto_open()

For Each cn In ThisWorkbook.Connections        'elimina connessioni
 cn.Delete
Next
 
Sheets("Foglio1").Visible = True
Sheets("Foglio3").Visible = True
Application.ScreenUpdating = False         'refresh schermo
                                                                           
Sheets(Array("Foglio1", "eCAV")).Select         'cancella fogli
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents

Sheets("foglio3").Select                    'azzera [importa] tabella modello
    Cells.Select
    Selection.Copy
    Sheets("eCAV").Select
    Cells.Select
    ActiveSheet.Paste

Dim fd As FileDialog                                    'seleziona cartella
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim CartellaSelezionata As Variant
With fd
If .Show = -1 Then
For Each CartellaSelezionata In .SelectedItems
miaCartella = CartellaSelezionata
Next
Else: Exit Sub
End If
End With
 
Sheets("foglio1").Select

Dim MyFile As String
MyFile = Dir(miaCartella & "*.dmo")

Do While MyFile <> ""
   With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & miaCartella & "" & MyFile, Destination:=Range("A1"))
        .Name = "SOM59054_NP2216552_BFA_REP1_1"
         .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = True
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
     MyFile = Dir
Loop

For i = 2 To 30         'imposta distanza tra report
 If Left(Cells(1, 1).Value, 10) = Left(Cells(1, i).Value, 10) Then
 dist = i - 1
 Exit For
End If
Next i

For i = 3 To 100                'offset verticale
  If IsNumeric(Trim(Cells(i, 3))) Then
  Offset = i
  Exit For
  End If
Next i

k = 0                           'valori misurati
For j = 0 To Cells(Columns.Count).End(xlToLeft).Column Step dist
Sheets("foglio1").Select
y = 1
For i = Offset To Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("eCAV")
     If IsNumeric(Cells(i, 2 + j)) And Cells(i, 2 + j) <> "" And Application.IsText(Cells(i - 1, 2 + j).Value) Then
     .Cells(25 + k, 5 + y) = Cells(i, 2 + j)
     y = y + 1
     End If
     End With
Next i
k = k + 1
Next j

Sheets("foglio1").Select
y = 1
For i = Offset To Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("eCAV")
     If IsNumeric(Cells(i, 2)) And Cells(i, 2) <> "" And Application.IsText(Cells(i - 1, 2).Value) Then
      .Cells(6, 5 + y) = Cells(i - 1, 2)            'nomi quote
      .Cells(7, 5 + y) = Cells(i, 3)                  'nominali
      .Cells(8, 5 + y) = Cells(i, 3) + Cells(i, 5)    'valori max toll
      .Cells(9, 5 + y) = Cells(i, 3) + Cells(i, 6)    'valori min toll
      y = y + 1
     End If
     End With
Next i
m = y

k = 0                   'valori misurati quote strane
For j = 0 To Cells(Columns.Count).End(xlToLeft).Column Step dist
y = m
For i = Offset To Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("eCAV")
        If (IsNumeric(Cells(i, 2)) And IsNumeric(Cells(i - 1, 2))) Or (IsNumeric(Cells(i, 2)) And Trim(Cells(i - 1, 2).Value = "")) Then
         .Cells(25 + k, 5 + y) = Cells(i, 2 + j)
         y = y + 1
      End If
      
'     If IsNumeric(Cells(i, 4)) And Cells(i, 1) Like "PROFILE" Then
'         .Cells(25 + k, 5 + y) = Cells(i, 4 + j)
'         y = y + 1
'         End If
    End With
Next i
k = k + 1
Next j

y = m               'nominali quote strane
For i = Offset To Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("eCAV")
        If (IsNumeric(Cells(i, 2)) And IsNumeric(Cells(i - 1, 2))) Or (IsNumeric(Cells(i, 2)) And Cells(i - 1, 2).Value = "") Then
      .Cells(6, 5 + y) = Cells(i, 1)            'nomi quote
      .Cells(7, 5 + y) = Cells(i, 3)                  'nominali
      .Cells(8, 5 + y) = Cells(i, 3) + Cells(i, 5)    'valori max toll
      .Cells(9, 5 + y) = Cells(i, 3) + Cells(i, 6)    'valori min toll
      y = y + 1
     End If
     End With
Next i

stringa = Cells(1, 1)
s = Split(stringa, "")
Sheets("eCAV").Cells(3, 1) = s(3)

Sheets("eCAV").Select
Dim a As String                    'autofit colonne                                     'autofit colonne di tutti i fogli
Dim b As Worksheet
a = ActiveSheet.Name
For Each b In ActiveWorkbook.Worksheets
On Error Resume Next
b.Activate
Cells.EntireColumn.AutoFit
Next b
  
Sheets("foglio1").Select
Cells.Select
Range("A76").Activate
Selection.ColumnWidth = 10

Sheets("Foglio1").Visible = False
Sheets("Foglio3").Visible = False
Application.ScreenUpdating = True         'refresh schermo

End Sub

di Vecchio Frac data: 08/10/2012 14:22:28
Secondo me (e ne sono convinto da sempre) è Dir che non restituisce i risultati che ci si aspetta, sarebbe meglio eseguire un loop tra i file con i metodi del FileSystemObject.
Ovviamente è difficilissimo darti una risposta corretta, che ti risolva il problema, perché bisognerebbe essere lì, vedere come sono strutturate le directory, i file di lavoro, le connessioni (ma sei proprio sicuro che per importare un file di testo devi proprio scomodare le QueryTables? più volte ho suggerito OpenText, ed è un'operazione che puoi fare anche con le semplici Open file For Input).
di gio (utente non iscritto) data: 08/10/2012 14:32:27
non è questione di scomodare querytables o usare Dir piuttosto che uqalcos'altro..è semplicemente questione che non conosco e non so come si usano le funzioni che dici te..come ti ho detto ho imparato l'altro giorno a fare le macro..e non sapevo esistessero altri metodi per importare file..
ergo..
come si fa? :D
di Vecchio Frac data: 08/10/2012 14:36:30
Oh LOL ma io non ti sto rimproverando o criticando, ti dico proprio "bravo" perchè hai cominciato a metterci il naso, a pasticciare e a provare. Ti ho mostrato che esistono molti modi per raggiungere una soluzione ad un problema. Molte volte a me capita di creare algoritmi complicati che poi possono essere semplificati con le istruzioni adatte (perchè in Excel le istruzioni adatte ci sono) :)
Ora recupero un po' di informazioni (inutile reinventare cose già scritte) e poi te le posto.
di gio (utente non iscritto) data: 08/10/2012 14:46:47
un ulteriore cosa che ho notato che forse puo aiutarti a capire il problema..
questo problema succede SEMPRE E SOLO alla prima [e qualche volta anche alla seconda] aprtura del programma, e solo questo programma [ne ho fatti in totale 6 tutti simili ma adattatti per file diversi..sono tutti praticametne uguali a parte il pezzo dove fa tutti i cicli e i calcoli ma solo questo da problemi]..
li ho confrontati e questo non ha nietn di diverso nella fase di apertura dei file...

di Vecchio Frac data: 08/10/2012 15:05:14
Tutta la parte tra Dim myfile as string e il Loop di chiusura del Do l'ho riscritta mantenendola simile alla tua. Il ciclo viene svolto sfruttando l'oggetto FileSystemObject che è più affidabile.
Il vantaggio di QueryTables è che mantiene i file txt che apre nello stesso foglio, sul quale poi vengono fatte le elaborazioni successive.
Io preferirei la soluzione con Workbooks.OpenText (una sola istruzione al posto di tutto l'ambaradan di QUeryTables), ma ha lo svantaggio di aprire un file nuovo per ogni txt importato (quindi bisogna ricopiare i dati da elaborare da questo nuovo file al file originario).

Dim f As Object, ff As Object
Const myPath = "C:..............."

    Set ff = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files
    
    For Each f In ff
        If Right(f, 4) = ".txt" Then
            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & f, Destination:=[A1])
                .Name = "SOM59054_NP2216552_BFA_REP1_1"
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePromptOnRefresh = False
                .TextFilePlatform = 1252
                .TextFileStartRow = 1
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileConsecutiveDelimiter = True
                .TextFileTabDelimiter = True
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = True
                .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
                .TextFileTrailingMinusNumbers = True
                .Refresh BackgroundQuery:=False
            End With
        End If
    Next

di gio (utente non iscritto) data: 08/10/2012 15:06:35
forse ho capito cosa è successo..io nel foglio 3 ho una tabella precompilata che esegue determinati calcoli in base ai dati che contiene..
creando questo programma mi è capitato di dover ampliare questa tabella..e di conseguenza anche le caselle contenti calcoli

roba del genere:
=SE(BN8="";((BN14-BN9)*2+BN14-BN9)/(BN12*6);

io ho selezionato il grupppo di caselle che contenevano calcoli e puntando il muose nell'angolino in basso a destra le ho trascinate in modo di copiare le formule [non so se hai capito cosa intendo]...comquneu è facendo questa operazione che poi quando eseguo la macro mi da sto problema...ho provato a copiare la macro in un nuovo foglio con la tabella originaria e infatti va..
l'ho notato perchè in una determinata casella mi segna invece che il classico errore "#VALORE!" che presumo indichi il fatto che le caselle a cui si riferiscono la forumula sono vuote, mi segna "######" che però non so cosa vuol dire..xd
di gio (utente non iscritto) data: 08/10/2012 15:22:39
ahahah ne ho scoperta un'altra di bella..

ho ricreato un altro file di excel e ricopiato la macro e adesso alla prima esecuzione funziona giusto [importa il numero giusto di file senza sovrapposizioni e importazioni sbagliate come ti dicevo prima]...ma alla seconda esecuzione fa quel casino...

bè la situazioen è gia migliorata perchè a me interessa che funzioni appena la apri [e non rieseguendola piu volta]...
però resta il fatto che coem errore è proprio stupido! xd
di gio (utente non iscritto) data: 09/10/2012 10:39:34
stavo provando a guardare il tuo codice..
ma tu usi un percorso costante..a me serve poterlo selezionare di volta in volta..
come si fa?
di Vecchio Frac data: 09/10/2012 11:23:45
Certo, era un esempio.
Quella parte non l'ho toccata ed è già implementata.
Eventualmente si può riscrivere per renderla più compatta.
Ovviamente adesso non si chiamerà più myPath ma mia_cartella, come nel tuo codice originario e la successiva istruzione
Set ff = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).Files
deve diventare
Set ff = CreateObject("Scripting.FileSystemObject").GetFolder(mia_cartella).Files
'seleziona cartella Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) If fd.Show = 0 Then Exit Sub miaCartella = fd.SelectedItems(1)
di gio (utente non iscritto) data: 09/10/2012 12:35:17
ho gia provato a fare le modifiche che hai scritto adesso..ma qualsiasi cartella che seleziono mi carica sempre la stessa cartella [non so dirti se è l'ultima cartella che avevo caricato con la vecchia versione del programma o cosa]..

di Vecchio Frac data: 09/10/2012 13:53:44
Tagliamo la testa al toro, allego la mia revisione della sub.
A me sembra funzionare correttamente, tranne nella parte di ThisWorkbook.Connections che XL2003 non digerisce.

Sub test()
Dim cn As Variant, mia_cartella As String, ff As Object, f As Object
Dim i As Integer, j As Integer, k As Integer, y As Integer, offset As Integer
Dim sh As Worksheet, dist As Integer, m As Integer


    'elimina connessioni
    For Each cn In ThisWorkbook.Connections
        cn.Delete
    Next
     
    Sheets("Foglio1").Visible = True
    Sheets("Foglio3").Visible = True
    
    'refresh schermo
    Application.ScreenUpdating = False

    'cancella fogli
    For Each sh In Sheets(Array("Foglio1", "eCAV"))
        sh.Cells.ClearContents
        [a1].Select
    Next
    
    'azzera [importa] tabella modello
    Sheets("foglio3").Cells.Copy Destination:=Sheets("ecav").[a1]
        
   
    'seleziona cartella
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = 0 Then Exit Sub
    mia_cartella = fd.SelectedItems(1)
    
    Sheets("foglio1").Select
    
    Set ff = CreateObject("Scripting.FileSystemObject").GetFolder(mia_cartella).Files
    
    For Each f In ff
        If Right(f, 4) = ".txt" Then
            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & f, Destination:=[a1])
                .Name = "SOM59054_NP2216552_BFA_REP1_1"
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .TextFilePromptOnRefresh = False
                .TextFilePlatform = 1252
                .TextFileStartRow = 1
                .TextFileParseType = xlDelimited
                .TextFileTextQualifier = xlTextQualifierDoubleQuote
                .TextFileConsecutiveDelimiter = True
                .TextFileTabDelimiter = True
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False
                .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
                .TextFileTrailingMinusNumbers = True
                .Refresh BackgroundQuery:=False
            End With
        End If
    Next
    
    Sheets("foglio1").Select
    
    'imposta distanza tra report
    For i = 2 To 30
        If Left(Cells(1, 1).Value, 10) = Left(Cells(1, i).Value, 10) Then
            dist = i - 1
            Exit For
        End If
    Next i
    
    'offset verticale
    For i = 3 To 100
        If IsNumeric(Trim(Cells(i, 3))) Then
            offset = i
            Exit For
        End If
    Next i
    
    'valori misurati
    k = 0
    For j = 0 To Cells(Columns.Count).End(xlToLeft).Column Step dist
        y = 1
        For i = offset To Cells(Rows.Count, 1).End(xlUp).Row
            With Sheets("eCAV")
                If IsNumeric(Cells(i, 2 + j)) And Cells(i, 2 + j) <> "" And Application.IsText(Cells(i - 1, 2 + j).Value) Then
                    .Cells(25 + k, 5 + y) = Cells(i, 2 + j)
                    y = y + 1
                End If
             End With
        Next i
        k = k + 1
    Next j
    
    Sheets("foglio1").Select
    y = 1
    For i = offset To Cells(Rows.Count, 1).End(xlUp).Row
        With Sheets("eCAV")
            If IsNumeric(Cells(i, 2)) And Cells(i, 2) <> "" And Application.IsText(Cells(i - 1, 2).Value) Then
                .Cells(6, 5 + y) = Cells(i - 1, 2)            'nomi quote
                .Cells(7, 5 + y) = Cells(i, 3)                  'nominali
                .Cells(8, 5 + y) = Cells(i, 3) + Cells(i, 5)    'valori max toll
                .Cells(9, 5 + y) = Cells(i, 3) + Cells(i, 6)    'valori min toll
                y = y + 1
            End If
         End With
    Next i
    m = y
    
    k = 0                   'valori misurati quote strane
    For j = 0 To Cells(Columns.Count).End(xlToLeft).Column Step dist
    y = m
    For i = offset To Cells(Rows.Count, 1).End(xlUp).Row
        With Sheets("eCAV")
            If (IsNumeric(Cells(i, 2)) And IsNumeric(Cells(i - 1, 2))) Or (IsNumeric(Cells(i, 2)) And Trim(Cells(i - 1, 2).Value = "")) Then
                .Cells(25 + k, 5 + y) = Cells(i, 2 + j)
                y = y + 1
            End If
          
    '       If IsNumeric(Cells(i, 4)) And UCase(Cells(i, 1)) = "PROFILE" Then
    '         .Cells(25 + k, 5 + y) = Cells(i, 4 + j)
    '         y = y + 1
    '       End If
        End With
    Next i
    k = k + 1
    Next j
    
    y = m               'nominali quote strane
    For i = offset To Cells(Rows.Count, 1).End(xlUp).Row
        With Sheets("eCAV")
            If (IsNumeric(Cells(i, 2)) And IsNumeric(Cells(i - 1, 2))) Or (IsNumeric(Cells(i, 2)) And Cells(i - 1, 2).Value = "") Then
                .Cells(6, 5 + y) = Cells(i, 1)            'nomi quote
                .Cells(7, 5 + y) = Cells(i, 3)                  'nominali
                .Cells(8, 5 + y) = Cells(i, 3) + Cells(i, 5)    'valori max toll
                .Cells(9, 5 + y) = Cells(i, 3) + Cells(i, 6)    'valori min toll
                y = y + 1
            End If
         End With
    Next i
    
    Sheets("eCAV").[A3] = Split([a1], "")(3)
    
    'autofit colonne
    For Each sh In ActiveWorkbook.Worksheets
        sh.Cells.EntireColumn.AutoFit
    Next
    
    Sheets("foglio1").[A76].ColumnWidth = 10
    
    Sheets("Foglio1").Visible = False
    Sheets("Foglio3").Visible = False
    Sheets("eCAV").Select
    Application.ScreenUpdating = True         'refresh schermo
    
End Sub

di gio (utente non iscritto) data: 09/10/2012 14:14:44
dev'esserci un errore..non importa nessun file..
di Vecchio Frac data: 09/10/2012 14:44:32
Non scoraggiarti, un po' di fantasia, leggi bene il codice ^_^
Leggendo i tuoi post precedenti noto che vuoi importare i file con estensione .dmo; quindi cambia la riga
If Right(f, 4) = ".txt" Then
con questa:
If Right(f, 4) = ".dmo" Then
e tutto andrà bene :)
di gio (utente non iscritto) data: 09/10/2012 16:28:19
eh dai questa era proprio da stupido se non la notavo..;)
anche correggendo quello non funzia giusto..
di Vecchio Frac data: 09/10/2012 21:13:14
Perchè non funzionerebbe? che errore riscontri?
di gio (utente non iscritto) data: 11/10/2012 09:06:37
scusa se rispondo solo adesso..

comunque avevi ragione..non mi sono accorto che molti file che importo hanno estenzione .DMO_CAPT e invece altri solo .DMO...per quello non li importava..
ho esteso il controllo if anche nell'altro caso e adesso funziona corretto..

hai anche cercato di ingannarmi mettendo un "false" in .TextFileSpaceDelimiter, ma me ne sono accorto! [mi importava tutto il file in un unica colonna] -.-
ahahahaha

per adesso non posso che ringraziarti per tutto l'aiuto che mi hai dato, adesso dovrei aver praticametne finito questo lavoro qundi non ti stresserò piu se non per qualche piccola correzione qua e là!
sei un grande! [ma fai questo come lavoro te o lo fai a tempo perso per beneficienza verso noi poveri programmatori amatoriali?]
di Vecchio Frac data: 11/10/2012 11:11:24
Sono contento che sia riuscito a risolvere brillantemente! allora metti la spunta su "Discussione risolta" :)
Non cercavo di ingannarti... è un refuso rimasto dalle mie prove :)
Questo comunque non è il mio lavoro... è un hobby (io mi occupo di sicurezza sul lavoro).
di gio (utente non iscritto) data: 11/10/2012 12:03:08
pesantuccio come hobby leggere capire e correggere i programmi di tutta la gente che scrive qui..ok che non è un forum enorme ma comqunue è difficile capire un programma [spesso senza avere a disposizione esempi ne neitne]..

Vuoi Approfondire?