Anthony,
in merito ad un tuo post di qualche settimana fa ove pensavi che i tuoi aiuti/suggerimenti erano fini a se stessi... allego la macro che alla fine della fiera sono riuscito a mettere in piedi.
Oltre ad aver fatto lavorare la macro in un nuovo file (mi terrorizzava un pò il fatto che lavorasse sul mio file che contiene i dati, non si sa mai), esporta i dati in 3 diversi formati (a scelta), file.txt file.excel97-2003, file.excel2007 a testiamonianza che a qualcosa sono serviti i tuoi aiuti/suggerimenti.
Ci sta sicuramente qualche commento di troppo (ma per me era indispensabile visto che sono pressochè analfabeta in merito a vba) e altrettanto sicuramente qualche codice di troppo, però alla fine ho ottenuto ciò che mi serviva.
Public Sub EsportaDati()
Application.ScreenUpdating = False
'memorizzo il nome del file originale completo di estensione
FileOrigine = ActiveWorkbook.Name
'memorizzo il nome del file originale senza estensione
SoloNomeOr = Replace(ActiveWorkbook.Name, ".xlsm", "")
'identifico le righe piene
ValRow = Worksheets("Foglio1").Cells(Rows.Count, 6).End(xlUp).Row
'aggiungo un nuovo file excel e ne memorizzo il nome (senza estensione che ancora non è attiva)
Workbooks.Add (1)
'memorizzo il solo nome del file aggiunto (al momento non ci sono estensioni)
FileNuovo = ActiveWorkbook.Name
'mi sposto sul sul nuovo file
Workbooks(FileNuovo).Activate
'inserisco intestazione nella prima riga
Range("A1").Value = "Date"
Range("B1").Value = "Time"
Range("C1").Value = "Open"
Range("D1").Value = "High"
Range("E1").Value = "Low"
Range("F1").Value = "Close"
Range("G1").Value = "Volume"
'formatto la seconda riga delle colonne interessate
Columns("A").ColumnWidth = 11 'allargo la colonna A che contiene le date per renderle visibili
Range("A2").Select
Selection.NumberFormat = "mm/dd/yyyy"
Range("B2:G2").Select
Selection.NumberFormat = "General"
Range("B2").Select
' centro la cella di destinazione dell'ora (necessario per eventuale salvataggio in txt)
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'indico il drive dove si trova il percorso
ChDrive "D:\"
'Percorso dove salvare il nuovo file e sua memorizzazione
Cartella = "D:\EXCEL\BANCA DATI\DATI ESPORTATI"
ChDir Cartella
scegliext:
'chiedo in che formato salvare il file ed aggiungo la relativa estensione
Ext = InputBox("Scegliere il formato in cui salvare il file:" & vbCrLf & vbCrLf & "1: Formato Excel 2007" & vbCrLf & "2: Formato Excel 97-2003" & vbCrLf & "3: Formato testo" & vbCrLf & "EXIT: Annulla operazione")
'se l'imput immesso non è corretto rimando all'input
If LCase(Ext) = "exit" Then GoTo termina
If Ext <> (1) And Ext <> (2) And Ext <> (3) Then GoTo scegliext
'assegno la relativa estensione
If Ext = (1) Then Ext = ".xlsx" 'attenzione, i file di excel 2007 hanno 2 estensione, .xlsm per i file con possibilità di macro e .xlsx per i file senza possibilità di macro
If Ext = (2) Then Ext = ".xls"
If Ext = (3) Then Ext = ".txt"
'rinomino il nome del nuovo file come il nome del file originale ed aggiunto l'estensione
FileNuovo = SoloNomeOr & Ext
'aggiungo le formule ed il copia incolla solo adesso perchè se file di testo devo cambiare il formato alla data e poi indirizzo il salvataggio
'scelto il tipo di data da inserire
If Ext = ".txt" Then
Range("A2").Formula = "=Right('[" & FileOrigine & "]Foglio1'!F2,4)&Left('[" & FileOrigine & "]Foglio1'!F2,2)&Mid('[" & FileOrigine & "]Foglio1'!F2,4,2)"
Else
Range("A2").FormulaLocal = "=Data(destra('[" & FileOrigine & "]Foglio1'!F2,4),sinistra('[" & FileOrigine & "]Foglio1'!F2,2),stringa.estrai('[" & FileOrigine & "]Foglio1'!F2,4,2))"
End If
'ed inserisco le altre formule alla seconda riga
Range("B2").FormulaLocal = "='[" & FileOrigine & "]Foglio1'!G2"
Range("C2").FormulaLocal = "='[" & FileOrigine & "]Foglio1'!H2"
Range("D2").FormulaLocal = "='[" & FileOrigine & "]Foglio1'!I2"
Range("E2").FormulaLocal = "='[" & FileOrigine & "]Foglio1'!J2"
Range("F2").FormulaLocal = "='[" & FileOrigine & "]Foglio1'!K2"
Range("G2").FormulaLocal = "='[" & FileOrigine & "]Foglio1'!L2"
'Seleziono la prima riga creata contenente le formule
Range("A2:G2").Select
Selection.Copy
'Seleziono il range su cui incollare ed incollo
Range("A2:G" & ValRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
'copio i risultati ottenuti e faccio incolla speciale per eliminare le formule
Range("A2:G" & ValRow).Select
Selection.Copy
Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
verifica:
'mi accerto se esiste già un file con il nome che devo salvare
On Error GoTo indirizza ' se non apre il file quindi errore vai a "indirizza"
'provo ad aprire il file con il nuovo nome da salvare per vedere se esiste
Workbooks.Open FileNuovo
'chiude il file aperto sopra
ActiveWorkbook.Close SaveChanges:=False
cambionome:
'se il file esiste chiedo con quale nuovo nome salvare il file
NomeAlter = InputBox("Il file " & FileNuovo & " è già esistente, inserire un nome alternativo per salvare il file" & vbCrLf & "EXIT per annullare l'operazione", "ATTENZIONE FILE GIA' ESISTENTE")
'se non viene inserito nessun nome rimando all'input
If LCase(NomeAlter) = "exit" Then GoTo termina
If NomeAlter = "" Then GoTo cambionome
'riassegno il nuovo nome richiesto ed aggiungo l'estensione
FileNuovo = LCase(NomeAlter) & Ext
'rimando a "verifica" per il verificare se esiste un file con il nuovo nome voluto
GoTo verifica
indirizza:
'indirizzo la macro in base al tipo di salvataggio che deve fare
If Ext = ".xlsx" Then GoTo excel2007
If Ext = ".xls" Then GoTo excel97
If Ext = ".txt" Then GoTo testo
excel2007:
'Salvo il foglio attivo
ActiveWorkbook.SaveAs Filename:=FileNuovo, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
GoTo termina
excel97:
'Salvo il foglio attivo
ActiveWorkbook.SaveAs Filename:=FileNuovo, FileFormat:=xlExcel8, CreateBackup:=False
GoTo termina
testo:
'elimino la prima riga che contiene l'intestazione perchè non la voglio sul file.txt
Rows("1:1").Select
Selection.Delete
Range("A1").Select
'salvo il file
ActiveWorkbook.SaveAs Filename:=FileNuovo, FileFormat:=xlText, CreateBackup:=False
GoTo termina
termina:
'Chiudo il nuovo file salvato
ActiveWorkbook.Close SaveChanges:=False
'Messaggio a video
If LCase(Ext) = "exit" Or LCase(NomeAlter) = "exit" Then
MsgBox ("Operazione Annullata")
Else
MsgBox ("Il file " + FileNuovo + " è stato correttamente salvato." & vbCrLf & vbCrLf & "Puoi trovarlo in " & Cartella)
'riposiziono il cursore sulla prima cella vuota della colonna F del file originale
Worksheets("Foglio1").Range("F1").Cells(ValRow + 1, 1).Select
End If
End Sub
Già che ci sono, ti chiedo gentilmente se puoi provarla perchè a mio parere qualcosa manca. In effetti tutte le macro che possiedo, funzionano sia se inserite in foglio1 che in moduli compresa la macro "Incolonna Dati" che tu stesso hai scritto.
Questa però, funziona perfettamente se inserita in moduli ma non funziona se inserita in foglio1. Ciò significa certamente che qualcosa a questa macro manca ed io vorrei capire cosa. Sempre che ciò ti sia possibile.
Grazie
Ciao
Registrazione
