(Excel)Creazione database con macro VBA

[ferrox82]

Salve a tutti...sono nuovo del forum e premetto che prima di arrendermi ho provato in tutti i modi!! ma...nn ci riesco!!
Ecco il mio problema:
Devo creare un database Excel dove andrò a riportare i risultati di un centinaio di questionari che sono stati realizzati anch'essi con Excel. Il formato del questionario è lo stesso per tutti i soggetti a cui l'ho proposto, ho fatto delle domande e loro mi hanno risposto in apposite celle . Ora devo prendere i valori nelle celle del questionario e le devo andare a copiare nel foglio nuovo, dove le colonne rappresentano la domanda fatta e le righe le rispettive risposte date da ciascun soggetto (i dati di ciascun soggetto corrispondono ad una riga del foglio). il tutto viene attivato da un bottone
Per ora ho fatto questo:

Private Sub CommandButton1_Click()
num = Application.Inputbox ("Quanti questionari vuoi registrare?",,,,,,1)

For counter =1 to num

ActiveCell.Cells(counter,1).FormulaR1C1 =_
"=+'[questionario1.xls]Anagrafica'!R7C6"

ActiveCell.Cells(counter,2).FormulaR1C1 =_
"=+'[questionario1.xls]Anagrafica'!R10C6"

Next counter

End sub

Dove questionario1 è il nome del file da aprire, Anagrafica il nome del primo foglio e R7C6, R10C6 sono le celle da cui voglio prelevare il dato. I l problema è che:
-devo prelevare 90 celle da ogni questionario e ...devo registrare 100 questionari!!(100 questionari sono 100 file!!) con il programma attuale per ogni cella che voglio registrare mi chiede di scegliere il file da cui prendere l'informazione e dare l'ok, il che rende la cosa lunghissima!!

come potrei fare a cambiare automaticamente il nome del file da cui prelevare i dati o comunque a registrare i questionari velocemente?

GRAZIE A TUTTI IN ANTICIPO PER L'ATTENZIONE, CREDO CHE SIA UN PROBLEMA INTERESSANTE...

[Anthony47]

Ciao ferrox e benvenuto nel forum.

Io procederei in questo modo:
La prima cosa da fare e’ mettere tutti e solo i file delle interviste in una unica directory.
Apri il file di sintesi e uno dei questionari compilati (lo chiamero’ Q1)
-sul file di sintesi, in Foglio2 (o su altro foglio libero), creati su riga 2 (in colonna A, B, etc) una sequenza di formule che puntano una dopo l’ altra alle celle della risposte del file Q1, rispettando la sequenza delle domande come le vuoi sintetizzare; bastera’ selezionare la cella su Foglio2 di Sintesi (es. A2), scrivere “=” (senza apici), cambiare file, identificare la cella giusta e cliccarla, la formula sara’ qualcosa come "='[questionario1.xls]Anagrafica'!F7
Fai in modo che in colonna A ci sia sempre un valore, meglio se non e’ una risposta (che potrebbe sempre essere lasciata vuota).
In questo modo ti crei una riga con le risposte del questionario, che poi andremo a incollare sul Foglio1 di Sintesi (il foglio che vuoi compilare con tutte le risposte una riga dopo l’ altra). Chiudi pure il file Q1.

Poi, se hai una certa familiarita’ con le macro, dai una occhiata a queste discussioni:
1) http://www.pc-facile.com/forum/viewtopic.php?t=61079
Qui ci interessa la parte di codice con cui faremo l’ inventario dei file presenti nella tua directory; sono le istruzioni fino a MsgBox "Ci sono " & etc etc.

2) http://www.pc-facile.com/forum/viewtopic.php?t=54712
Qui ci interessa il codice che cambia il collegamento a file esterno su un foglio di lavoro; diciamo da “'2 - quale e' il link attuale” fino a Esci:

Infine useremo altre istruzioni per copiare la riga 2 di Foglio2 in coda alle risposte gia’ accumulate su Foglio1; qualcosa come

Codice: Seleziona tutto

Sheets(“Foglio2”).select
Range("2:2").copy
Sheets("Foglio1").select
Range("A65536").end(xlup).offset(1,0).select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Range("A1").end(xltoright).offset(0,1).value = MatrLinks(1)    'Nome File con risposte

Riepilogando:
- metti tutti e solo i file di risposta in una directory
- prepara il file Sintesi come descritto
- assembla una macro utilizzando gli spezzoni di codice segnalati per:
>>Creare l’ elenco dei file da esaminare (primo riferimento dato)
>>in coda, fai un ciclo For/next che inizia con For I = 1 To .FoundFiles.Count (e ovviamente finisce con Next I) in cui inserisci il codice che cambia il collegamento a file esterno (secondo riferimento dato) E il codice dato sopra per copiare le risposte da foglio2 a foglio1

Lanciando la macro, le risposte dovrebbero essere lette una dopo l’ altra, sintetizzate su Foglio2 di sintesi (tramite le formule che ti ho fatto mettere) e poi accumulate su Foglio1 di Sintesi.

Vedi se quanto suggerito ti sembra perseguibile, guarda le discussioni che ti ho segnalato e prova a comporre la macro; come sempre: 2 COPIE DI BACKUP prima di fare esperimenti.

Se hai difficolta’, dubbi o domande, siamo qua; col tempo si cerca di rispondere a tutti.

Ciao.

[ferrox82]

ciao Anthony!
volevo subito ringraziarti x la tua risposta ed inoltre hai capito perfettamente il problema!! Tornando ai due riferimenti che mi hai dato, ho provato a risolvere il problema adattando solo il codice del primo riferimento, (dal topic "importare dati da files differenti", di gik), il programmino funziona ma credo che la tua soluzione sia qualcosa di molto meglio!
Dimenticavo di dirti che ogni questionario (che è un file Excel e non so ancora se gli darò nomi diversi), è composto da 7 fogli, e da ogni foglio dovrò "prendere" indicativamente 15 celle con il relativo valore.
Innanzitutto ho messo tutti i file in un'unica directory, poi ho predisposto le celle della riga 2 del foglio 2, poi ho scritto la macro, unendo i due spezzoni che mi hai indicato precedentemente e integrandoli con il codice che mi hai passato tu:


Sub registra()

SourceDir = "C:\Desktop\questionari

Set fs = Application.FileSearch
With fs
.LookIn = SourceDir
.SearchSubFolders = False
.Filename = "*.*"
If .Execute() = 0 Then
MsgBox "No files in " & SourceDir
Exit Sub
End If
End With

'fine primo riferimento

For i = 1 To .FoundFiles.Count

'2 qual è il link attuale

MatrLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If IsEmpty(MatrLinks) Then GoTo Esci
'MsgBox (MatrLinks(1))

' 2b - Segnala Link corrente e nuovo e scelta Azione
Mess = "Vuoi sostituire >> " & MatrLinks(1) & vbCrLf & " Con >> " & FullNome & vbCrLf & ">> SI per Confermare; NO per Cambiare; CANCEL per abortire"

scelta = MsgBox(Prompt:=Mess, Buttons:=vbYesNoCancel)

If scelta = 2 Then GoTo Esci 'Cancel
If scelta = 7 Then GoTo Scegli 'NO = Riseleziona

'3 - Cambia il link
ActiveWorkbook.ChangeLink Name:=MatrLinks(1), NewName:= _
FullNome, Type:= _
xlExcelLinks

Sheets(“Foglio2”).Select
Range("2:2").Copy
Sheets("Foglio1").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Range("A1").End(xlToRight).Offset(0, 1).Value = MatrLinks(1) 'Nome File con risposte

Next i

End Sub

Sicuramente ci saranno diverse cose che non vanno, perchè il programma non gira, il debug mi segnala:

1) if scelta =7 then goto Scegli -->etichetta non definita (e così anche per gli altri then...goto)

2) nel contatore For i=1 to .FoundFiles.Count -->mi dice che è necessario un oggetto, e prima ancora nel contatore mi dava un riferimento non valido

3)problemi con la selezione del foglio2

La soluzione che mi hai proposto mi sembra l'ideale, però ci sono diversi problemi nell'apertura file e nel ciclo di cambio collegamento-compilazione riga...puoi segnalarmi le possibili correzioni?

Grazie mille, io e la mia Tesi te ne saremo molto grati!!

[Anthony47]

Ho inserito qualche istruzione in piu' (vedi ++++++) e ne ho modificate alcune per (credo) risolvere i problemi segnalati.
La nuova macro e':

Codice: Seleziona tutto

Sub registra()

SourceDir = "C:\Desktop\questionari "

Set fs = Application.FileSearch
With fs
.LookIn = SourceDir
.SearchSubFolders = False
.Filename = "*.*"
If .Execute() = 0 Then
MsgBox "No files in " & SourceDir
Exit Sub
End If
End With

'fine primo riferimento
With fs                        '++++++++++
For i = 1 To .FoundFiles.Count

'2 qual è il link attuale

MatrLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If IsEmpty(MatrLinks) Then GoTo Esci
'MsgBox (MatrLinks(1))

' 2b - Segnala Link corrente e nuovo e scelta Azione
Mess = "Vuoi sostituire >> " & MatrLinks(1) & vbCrLf & " Con >> " & FullNome & vbCrLf & ">> SI per Confermare; NO per Saltare questo File; CANCEL per abortire"  'XXXXXXXXXXXX

scelta = MsgBox(Prompt:=Mess, Buttons:=vbYesNoCancel)


If scelta = 2 Then GoTo Esci 'Cancel = termina il processo senza completare XXXXXXXX
If scelta = 7 Then GoTo Salta 'NO = Skippa questo file        XXXXXXXXXXXXXX

'3 - Cambia il link
ActiveWorkbook.ChangeLink Name:=MatrLinks(1), NewName:= _
FullNome, Type:= _
xlExcelLinks

Sheets("Foglio2").Select             'XXXXXXXXXXXXX
Range("2:2").Copy
Sheets("Foglio1").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Range("A1").End(xlToRight).Offset(0, 1).Value = MatrLinks(1) 'Nome File con risposte

Salta:                   '++++++++++++
Next i
Esci:                    '++++++++++++
End Sub

Il messaggio Si /No/Cancel consente di:
-inserire i dati di quel file (Si)
-skippare il file e continuare (No)
-abortire il processo (Cancel)

Direi che questo potrebbe essere utile in fase di debug; completato il quale le istruzioni Scelta = etc etc, If Scelta = 2 etc, If Scelta = 3 etc possono essere commentate per avere un processo piu' automatico.

Ciao, fai sapere.

[ferrox82]

Ciao Anthony! ho riprovato di nuovo il codice che mi hai dato ieri, qualcosa ha migliorato perchè con il ciclo With fs..,prima del for ha smesso di darmi gli errori di debug sul ciclo for.

Il problema persistente deve essere riferito in qualche modo a FullNome e al cambio di link in quanto:

1) Nella MsgBox viene visualizzato correttamente il nome del file corrente ma non viene visualizzato quello con cui fare la sostituzione

2) Se scelgo SI nella MsgBox mi appare subito un messaggio di interruzione: Metodo 'Changelink' dell'oggetto '_workbook' non riuscito, e se da qui vado in debug sono selezionate in giallo le 3 righe di codice da '3-cambia il link a Sheets("foglio2")

Quindi c'è un problema con il cambio di link, premetto che nella cartella di origine ho messo 3 file quindi nella MsgBox il nome di un altro file sarebbe dovuto comparire..scusa se ti chiedo ancora aiuto ma l'help in linea non mi è servito a molto...

Grazie infine nuovamente...

[Anthony47]

Il problema persistente deve essere riferito in qualche modo a FullNome e al cambio di link...

Diagnosi giusta; infatti FullNome si era perso nell' assemblaggio della macro per cui la variabile era vuota.

Ho modificato (per la "penultima volta") la macro; ho evidenziato con --- una istruzione tolta, con MMM le istruzioni modificate, e con +++MMM le istruzioni aggiunte.
Tieni presente che forse hai definito male la SourceDir; penso che debba essere C:\Documents and Settings\NomeUtente\Desktop\etc etc.

Sub registra()

SourceDir = "C:\Desktop\questionari "

Set fs = Application.FileSearch
With fs
.LookIn = SourceDir
.SearchSubFolders = False
.Filename = "*.xls" 'MMMMMMMMMMM
If .Execute() = 0 Then
MsgBox "No files in " & SourceDir
Exit Sub
End If
End With

'fine primo riferimento
'With fs '-------------
For i = 1 To fs.FoundFiles.Count 'MMMMMMMMMMMMMM

'2 qual è il link attuale

MatrLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If IsEmpty(MatrLinks) Then GoTo Esci
'MsgBox (MatrLinks(1))
FullNome = fs.FoundFiles(i) 'MMMMMMMMMMM
' 2b - Segnala Link corrente e nuovo e scelta Azione
Mess = "Vuoi sostituire >> " & MatrLinks(1) & vbCrLf & " Con >> " & FullNome & vbCrLf & ">> SI per Confermare; NO per Saltare questo File; CANCEL per abortire" 'XXXXXXXXXXXX

scelta = MsgBox(Prompt:=Mess, Buttons:=vbYesNoCancel)


If scelta = 2 Then GoTo Esci 'Cancel = termina il processo senza completare XXXXXXXX
If scelta = 7 Then GoTo Salta 'NO = Skippa questo file

'3 - Cambia il link
ActiveWorkbook.ChangeLink Name:=MatrLinks(1), NewName:= _
FullNome, Type:= _
xlExcelLinks

Sheets("Foglio2").Select
Range("2:2").Copy
Sheets("Foglio1").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Range("A1").Range("IV1").End(xlToLeft).Offset(0, 1).Value = MatrLinks(1) 'Nome File con risposte MMMMMMMMMMM

Salta:
Next i
Esci:
End Sub

Che sia la volta buona? Ciao.

[Anthony47]

Anche a te dico quello che ho detto a Frank su un altro topic (vedi http://www.pc-facile.com/forum/viewtopi ... 662#371662):

nel caso ti servisse, puoi ordinare i nome file usando questa istruzione invece della .Execute usata nella macro di ferrox82.

Codice:
If .Execute(SortBy:=msoSortbyFileName, SortOrder:=msoSortOrderAscending) = 0 Then

Ri-ciao.

[ferrox82]

Ciao Anthony! 6 veramente un grande!

Ho provato la macro e funziona davvero bene! L'unica cosa è che mi sono reso conto che le celle da prelevare da ogni questionario molte di più di 256 per cui i dati di ogni singolo questionario non stanno su una sola riga..
Per cui ho provato excel 2007 che di colonne ne ha circa 16000 ma però da diversi errori di debug perchè credo che il linguaggio sia cambiato.
Cmq l'importante è che sul 2003 giri bene... Penso che alla fine integrerò il tuo ultimo codice con quello del primo riferimento della tua prima risposta, in quanto i questionari arrivati li metto in una cartella, la msg box mi dice quanti ce ne sono, poi non metto la parte "vuoi sostituire ... con...SI NO ANNULLA" perchè se ho 30 file in cartella tutte le volte mi esce la msg box e la cosa credo rallenti un pò troppo il processo...

Cmq quando verificherò il funzionamento posterò la macro definitiva...nel frattempo mi riprometto di nn disturbarti più ma...non contarci troppo!!

[Anthony47]

Oppure, se hai meno di 250 questionari, puoi assemblare le risposte "in verticale"....
Gli interventi sul processo e sulla macro sono abbastanza limitali, io al tuo posto ci proverei.

Ciao.

[ferrox82]

Come promesso ecco la versione definitiva (ma nn troppo ). Grazie ai consigli di Anthony ho prodotto questo, le celle da importare da ogni singolo questionario sono più di 500, e quindi nn ci stanno su una sola riga. Visto che per ragioni pratiche mettere le risposte in colonna non risultava molto utile per andare poi a fare delle analisi, ho deciso di registrare i dati registrando dei "blocchi" di celle, selezionate tramite range, in quanto sono dati relativi ad un singolo fornitore, e impilandoli andrò poi a vedere i dati di tutti i fornitori. Inoltre i dati non sono più registrati su un unico foglio, ma su più fogli diversi, fermo restando "Foglio2" come foglio di appoggio per tutti. In questo modo, ad ogni sezione del questionario faccio corrispondere un foglio di registrazione.
A tal proposito volevo domandare ad Anthony 2 cose:

1)perchè la macro funziona correttamente solo dopo alcune attivazioni?da cosa dipende questo fatto? nelle prime attivazioni ha delle difficoltà a fare il cambio di link e quindi tende a ripetere i dati

2)è possibile, a fine registrazione spostare il file registrato dalla cartella Risposte questionari ad un' altra dove andrò a mettere i file già registrati al fine di evitare di registrare nuovamente il file?

Ecco per ora la macro:


Sub registra2()
SourceDir = "C:\Documents and Settings\xxx \Desktop\Risposte questionari"
Set fs = Application.FileSearch
With fs
.LookIn = SourceDir
.SearchSubFolders = False
.Filename = "*.xls" 'MMMMMMMMMMM
If .Execute() = 0 Then
MsgBox "No files in " & SourceDir
Exit Sub
End If
End With
'fine primo riferimento
With fs
MsgBox ("il numero di files nella cartella è: " & fs.FoundFiles.Count)
For i = 1 To fs.FoundFiles.Count 'MMMMMMMMMMMMMM
'2 qual è il link attuale
Matrlinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If IsEmpty(Matrlinks) Then GoTo Esci
'MsgBox (MatrLinks(1))
Fullnome = fs.FoundFiles(i) 'MMMMMMMMMMM
Mess = "Vuoi registrare il file" & Fullnome & vbCrLf & "? SI per confermare, NO per saltare questo file, CANCEL per annullare"

scelta = MsgBox(Prompt:=Mess, Buttons:=vbYesNoCancel)

If scelta = 2 Then GoTo Esci

If scelta = 7 Then GoTo Salta

'inserimento di una informazione aggiuntiva che andrà poi copiata nel foglio2
Mess = "Digita il codice del cliente per il file " & Fullnome & vbCrLf

codice = Application.InputBox(Prompt:=Mess, Title:="CODICE CLIENTE")

' 2b - Segnala Link corrente e nuovo e scelta Azione

'3 - Cambia il link
ActiveWorkbook.ChangeLink Name:=Matrlinks(1), NewName:= _
Fullnome, Type:= _
xlExcelLinks

Sheets("Foglio2").Select
Range("A13:G15").Copy
Sheets("Foglio1").Select
Range("A65536").End(xlUp).Offset(1, 0).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
‘prima selezione di foglio2 da copiare
Sheets("Foglio2").Select
Range("A19:G21").Copy
Sheets("Foglio3").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

‘seconda selezione di foglio2 da copiare
Sheets("Foglio2").Select
Range("A6:I9").Copy
Sheets("Foglio4").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
‘copia di riga2

Sheets("Foglio2").Select
Range("A2").Select
ActiveCell.Value = codice
Range("2:2").Copy
Sheets("Foglio5").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False




Sheets("Foglio2").Select
Range("A24:D44").Copy
Sheets("Foglio6").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Salta:

Next i
Sheets("Anagrafica-Produzione-Qualità").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
MsgBox ("IL NUMERO TOTALE DI QUESTIONARI REGISTRATI FINORA E': " & ActiveCell.Row - 2)
‘ -2 perché avrò una riga con le intestazioni e inoltre la cella selezionata è nella riga sotto l’ultimo questionario inserito

Esci:
End With

End Sub

Grazie di nuovo ad Anthony per l'aiuto!

[Anthony47]

Ciao ferrox,
Non so perche’ la macro “fa fatica a ingranare”; vedo che hai lasciato i msgbox, le loro informazioni dicono niente di utile? Se metti un break sull’ istruzione successiva a ActiveWorkbook.ChangeLink (che e’ Sheets("Foglio2").Select), e vai su una delle celle che ha il link, lo vedi cambiato (nella barra della formula) o no? E se, mentre sei su una di queste celle, fai F2 (edit) ed Enter, vedi perc caso il risultato cambiare?

Comunque, se vuoi spostare il file dalla directory principale a una di servizio, puoi inserire queste istruzioni prima di Next I (o prima di “Salta:”, se vuoi spostare solo i file presi in considerazione, e non quelli al cui msgbox hai risposto “NO”):

Codice: Seleziona tutto

MovedFile = Replace(FullNome, "C:\Documents and Settings\xxx \Desktop\Risposte questionari", "C:\Documents and Settings\xxx \Desktop\Risposte questionari\Elaborati"
Name FullNome As MovedFile

La directory “..\Elaborati” deve gia’ esistere.
Ciao.

[paola_pier]

Ciao. Il mio problema è analogo.
Un questionario in formato file excel composto da più fogli è stato inviato ad una serie di aziende.
Le loro risposte le dovrei inserire in un nuovo file x poterne poi effettuare tutte le elaborazioni del caso.
Anche qui le colonne del nuovo file rappresenteranno le domande mentre le righe le risposte delle aziende.
Il problema è che uso Excel 2007 e l'oggetto File Search da voi usano non è supportato, per cui il codice a cui siete giunti, seppur faccia al caso mio al 100%, non mi è utile.
Le ho provate tutte ma non riesco ad arrivare ad una soluzione.
Please, help me!
Vi ringrazio.

[Anthony47]

Ciao paola_pier e benvenuto/a nel forum.
Credo che si tratti di operazione una tantum, quindi il sugerimento e' che in un "foglio Indice" ti crei l' elenco dei file di risposta usando un file .bat come spiegato in questa discussione:
viewtopic.php?f=26&t=75455#p428651

Con queste istruzioni crei il file pippo123.txt e ne importi il contenuto nel foglio "Indice".
A questo punto lavorerai su questo elenco (col B di Indice) invece che sull' elenco creato con la FileSearch.
Se serve ulteriore aiuto posta ancora.

Ciao