Penso che la soluzione di Flash si meglio per le mie esigenze.
Grazie
Moderatori: Anthony47, Flash30005
Flash30005 ha scritto:Prima di approfondire per un errore che ho (memoria esaurita) vorrei sapere se questo file
va bene come output (sono le prime 400 righe)
ciao
Sub CreaArch3()
Dim VArr
Perc = ThisWorkbook.Path & "\"
NomeA = ThisWorkbook.Name
Dim MyFile, MyStr As String
NFoglio = ActiveSheet.Name
Worksheets(NFoglio).Select
If Dir(Perc & "Archivio", vbDirectory) = "" Then
MkDir (Perc & "Archivio")
End If
Worksheets(NFoglio).Range("A2:IV10000").Clear
MyFile = "Cat.Csv"
Workbooks.Open Filename:=Perc & "cat.csv"
Application.DisplayAlerts = False
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = True
URF = Workbooks(MyFile).Worksheets("Cat").Range("A" & Rows.Count).End(xlUp).Row
For RRF = 2 To URF
VArr = Worksheets("Cat").Range("A" & RRF & ":T" & RRF).Value
Workbooks(NomeA).Worksheets(NFoglio).Range("A" & RRF).Value = VArr(1, 3)
Bstr = VArr(1, 4)
Workbooks(NomeA).Worksheets(NFoglio).Range("B" & RRF).Value = Bstr
Workbooks(NomeA).Worksheets(NFoglio).Range("C" & RRF).Value = VArr(1, 10)
Workbooks(NomeA).Worksheets(NFoglio).Range("D" & RRF).Value = Bstr & "-" & VArr(1, 1) & "-" & VArr(1, 3) '<<<< memoria esaurita
Workbooks(NomeA).Worksheets(NFoglio).Range("E" & RRF).Value = VArr(1, 6)
Workbooks(NomeA).Worksheets(NFoglio).Range("G" & RRF).Value = VArr(1, 5)
Workbooks(NomeA).Worksheets(NFoglio).Range("H" & RRF).Value = VArr(1, 1) & "-" & VArr(1, 2)
Workbooks(NomeA).Worksheets(NFoglio).Range("I" & RRF).Value = Val(VArr(1, 7)) * 1.3
Workbooks(NomeA).Worksheets(NFoglio).Range("J" & RRF).Value = Val(VArr(1, 7)) * 1.2
Workbooks(NomeA).Worksheets(NFoglio).Range("K" & RRF).Value = VArr(1, 7)
Workbooks(NomeA).Worksheets(NFoglio).Range("N" & RRF).Value = VArr(1, 8)
Workbooks(NomeA).Worksheets(NFoglio).Range("P" & RRF).Value = 1
Workbooks(NomeA).Worksheets(NFoglio).Range("S" & RRF).Value = VArr(1, 9)
Workbooks(NomeA).Worksheets(NFoglio).Range("T" & RRF).Value = 7
Next RRF
Workbooks(MyFile).Close savechanges:=False
If Len(Dir(Perc & "Archivio\" & MyFile)) > 0 Then Kill Perc & "Archivio\" & MyFile
'Name Perc & MyFile As Perc & "Archivio\" & MyFile
Worksheets(NFoglio).Select
' Columns("A:T").EntireColumn.AutoFit
Range("A1").Select
End Sub
Sub CreaArch3()
Dim VArr
Perc = ThisWorkbook.Path & "\"
NomeA = ThisWorkbook.Name
Dim MyFile, MyStr As String
NFoglio = ActiveSheet.Name
Worksheets(NFoglio).Select
If Dir(Perc & "Archivio", vbDirectory) = "" Then
MkDir (Perc & "Archivio")
End If
Worksheets(NFoglio).Range("A2:IV10000").Clear
MyFile = "Cat.Csv"
Workbooks.Open Filename:=Perc & "cat.csv"
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), TrailingMinusNumbers:=True
ActiveWindow.SmallScroll Down:=-3
URF = Workbooks(MyFile).Worksheets("Cat").Range("A" & Rows.Count).End(xlUp).Row
For RRF = 2 To URF
VArr = Worksheets("Cat").Range("A" & RRF & ":T" & RRF).Value
Workbooks(NomeA).Worksheets(NFoglio).Range("A" & RRF).Value = VArr(1, 3)
Bstr = VArr(1, 4)
Workbooks(NomeA).Worksheets(NFoglio).Range("B" & RRF).Value = Bstr
Workbooks(NomeA).Worksheets(NFoglio).Range("C" & RRF).Value = VArr(1, 10)
Workbooks(NomeA).Worksheets(NFoglio).Range("D" & RRF).Value = Bstr & "-" & VArr(1, 1) & "-" & VArr(1, 3)
Workbooks(NomeA).Worksheets(NFoglio).Range("E" & RRF).Value = VArr(1, 6)
Workbooks(NomeA).Worksheets(NFoglio).Range("G" & RRF).Value = VArr(1, 5)
Workbooks(NomeA).Worksheets(NFoglio).Range("H" & RRF).Value = VArr(1, 1) & "-" & VArr(1, 2)
Workbooks(NomeA).Worksheets(NFoglio).Range("I" & RRF).Value = Val(VArr(1, 7)) * 1.3
Workbooks(NomeA).Worksheets(NFoglio).Range("J" & RRF).Value = Val(VArr(1, 7)) * 1.2
Workbooks(NomeA).Worksheets(NFoglio).Range("K" & RRF).Value = VArr(1, 7)
Workbooks(NomeA).Worksheets(NFoglio).Range("N" & RRF).Value = VArr(1, 8)
Workbooks(NomeA).Worksheets(NFoglio).Range("P" & RRF).Value = 1
Workbooks(NomeA).Worksheets(NFoglio).Range("S" & RRF).Value = VArr(1, 9)
Workbooks(NomeA).Worksheets(NFoglio).Range("T" & RRF).Value = 7
Next RRF
Workbooks(MyFile).Close savechanges:=False
If Len(Dir(Perc & "Archivio\" & MyFile)) > 0 Then Kill Perc & "Archivio\" & MyFile
'Name Perc & MyFile As Perc & "Archivio\" & MyFile
Worksheets(NFoglio).Select
' Columns("A:T").EntireColumn.AutoFit
Range("A1").Select
End Sub
Columns("I:K").NumberFormat = "0.00"
Columns("I:K").NumberFormat = "0.00"
Sub CreaArch222()
Dim VArr, nFoglio As String
'
Perc = ThisWorkbook.Path & "\"
nFoglio = ActiveSheet.Name
ActiveSheet.Range("A2").Resize(Rows.Count - 1, Columns.Count).Clear
'
Sheets.Add
'
myCsv = Perc & "cat.csv"
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myCsv _
, Destination:=Range("A1"))
.Name = "cat"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 2)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'
URF = Range("A" & Rows.Count).End(xlUp).Row
'
VArr = ActiveSheet.Range("A2:T" & URF).Value
For RRF = 1 To URF - 1
Worksheets(nFoglio).Range("A" & RRF + 1).Value = VArr(RRF, 3)
Worksheets(nFoglio).Range("B" & RRF + 1).Value = VArr(RRF, 4)
Worksheets(nFoglio).Range("C" & RRF + 1).Value = VArr(RRF, 10)
Worksheets(nFoglio).Range("D" & RRF + 1).Value = VArr(RRF, 4) & "-" & VArr(RRF, 1) & "-" & VArr(RRF, 3)
Worksheets(nFoglio).Range("E" & RRF + 1).Value = VArr(RRF, 6)
Worksheets(nFoglio).Range("G" & RRF + 1).Value = VArr(RRF, 5)
Worksheets(nFoglio).Range("H" & RRF + 1).Value = VArr(RRF, 1) & "-" & VArr(RRF, 2)
Worksheets(nFoglio).Range("I" & RRF + 1).Value = Val(VArr(RRF, 7)) * 1.3
Worksheets(nFoglio).Range("J" & RRF + 1).Value = Val(VArr(RRF, 7)) * 1.2
Worksheets(nFoglio).Range("K" & RRF + 1).Value = VArr(RRF, 7)
Worksheets(nFoglio).Range("N" & RRF + 1).Value = VArr(RRF, 8)
Worksheets(nFoglio).Range("P" & RRF + 1).Value = 1
Worksheets(nFoglio).Range("S" & RRF + 1).Value = VArr(RRF, 9)
Worksheets(nFoglio).Range("T" & RRF + 1).Value = 7
'Workbooks("output_7.xls").Worksheets(NFoglio).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = A
Next RRF
'
Sheets(nFoglio).Select
ActiveWorkbook.SaveAs Filename:=Perc & "Output_7.csv", _
FileFormat:=xlCSV, CreateBackup:=False, local:=True
'
Stop
ThisWorkbook.Close savechanges:=False
End Sub
Pertanto la mia proposta e' di partire da un file "pippo.xlsm" (il nome e' a libera scelta), contenente un unico foglio di nome output_7, contenente solo le intestazioni in riga 1
ho inserito comunque uno Stop prima della chiusura del file per gestire eventuali dimenticanze in fase di preparazione del file, la riga si puo' eliminare quando il debug e' completato
Workbooks(NomeA).Worksheets(NFoglio).Range("I" & RRF).Value = Val(Replace(VArr(1, 7), ",", ".")) * 1.3
Workbooks(NomeA).Worksheets(NFoglio).Range("J" & RRF).Value = Val(Replace(VArr(1, 7), ",", ".")) * 1.2
Torna a Applicazioni Office Windows
Macro che scatta quando cambia dato in un altro file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 14 |
Excel: formula automatica per evidenziare prodotto scaduto Autore: gamma_ray |
Forum: Applicazioni Office Windows Risposte: 3 |
Salvare file excel in formato html escludendo le immagini Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 10 |
Problema con macro copia e rinomina file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
formula excel non visualizza risultato Autore: tommasog |
Forum: Applicazioni Office Windows Risposte: 6 |
Visitano il forum: Nessuno e 59 ospiti