Non so il motivo per cui non hai ottenuto risultati con le "settine", io ho ottenuto un file mostro, poco pratico da gestire, dopo qualche ora di elaborazione notturna.
Per evitare la creazioni di risultati "mostruosi" ho modificato il codice in modo da creare tanti file di circa 70 Mbyte, numerati come _001, _002, etc
Le modifiche prevedono l'aggiunta di una nuova Sub SaveNow, piu' modifiche alla Sub MainBah e alla Sub CkArr. Il nuovo codice complessivo:
- Codice: Seleziona tutto
Dim wArr() As Long, myI As Long, Level As Long, LastN As Long, SaveNum As Long, iFName As String
Dim OArr(1 To 10000, 0 To 9) As Long, LB As Double, ColOut As Long, myColl As Long
Sub MainBah()
Dim myTim As Single
'
LastN = 90
Level = Range("A1").Value
Range("A2").Resize(Rows.Count - 1, Level * 3 + 5).ClearContents
DoEvents: DoEvents
LB = 10 ^ (-15)
ColOut = 1
ReDim wArr(1 To Level)
myTim = Timer
Debug.Print ">>> Starting, " & Level, Now
iFName = ThisWorkbook.FullName
ThisWorkbook.Sheets(1).Cells(1, 3) = "'" & Format(SaveNum, "0000")
DoEvents
Application.ScreenUpdating = False
myI = 0
myColl = 0
Call RecurBah(1)
If myI > 0 Then
nextr = Cells(Rows.Count, ColOut).End(xlUp).Row + 1
If nextr + myI > Rows.Count Then
ColOut = ColOut + Level + 2
nextr = 2
End If
Cells(nextr, ColOut).Resize(myI, Level + 1).Value = OArr
End If
Application.ScreenUpdating = True
Debug.Print "<<< Completed:", Now
MsgBox ("Completato, sec. " & Format(Timer - myTim, "0.00"))
End Sub
Sub RecurBah(ByVal Colonna As Long)
'
If Colonna = Level Then
Do
wArr(Colonna) = wArr(Colonna) + 1
Call CkArr(Level)
If wArr(Colonna) - Colonna + Level >= LastN Then
Exit Do
End If
Loop
goBack = True
Exit Sub
Else
If Not wArr(Colonna) - Colonna + Level >= LastN Then
Do
wArr(Colonna) = wArr(Colonna) + 1
wArr(Colonna + 1) = wArr(Colonna)
If wArr(Colonna) - Colonna + Level >= LastN Then Exit Do
Call RecurBah(Colonna + 1)
Loop
End If
End If
End Sub
Sub CkArr(J As Long)
Dim I As Long, WVal As Long, SRVal As Double
'
If myColl = 2147483647 Then
Debug.Print Now
myColl = 0
End If
myColl = myColl + 1
'' If myColl = 2147483647 Then myColl = 0
For I = 1 To J
WVal = WVal + wArr(I) ^ 2
Next I
SRVal = WVal ^ 0.5
If (SRVal - Int(SRVal)) < LB Then
myI = myI + 1 '
OArr(myI, 0) = myColl
For I = 1 To Level
OArr(myI, I) = wArr(I)
Next I
If myI = UBound(OArr) Then
nextr = Cells(Rows.Count, ColOut).End(xlUp).Row + 1
If nextr + myI > Rows.Count Then
ColOut = ColOut + Level + 2
nextr = 2
'Se superiore a.. salva copia:
If ColOut > 10 Then
Application.ScreenUpdating = True
DoEvents
Application.ScreenUpdating = False
Call SaveNow(1)
End If
End If
Cells(nextr, ColOut).Resize(myI, Level + 1).Value = OArr
Erase OArr
myI = 0
DoEvents
End If
End If
End Sub
Sub SaveNow(Dummy As Long)
'
Debug.Print Now, SaveNum, myColl
'Mostra avanzamento:
Application.ScreenUpdating = True
DoEvents
'Salva copia:
ThisWorkbook.SaveCopyAs Replace(iFName, ".xlsm", "_" & Format(SaveNum, "0000") & ".xlsm", , , vbTextCompare)
'reset valori:
SaveNum = SaveNum + 1
ThisWorkbook.Sheets(1).Cells(1, 3) = "'" & Format(SaveNum, "0000")
ColOut = 1
ThisWorkbook.Sheets(1).Range("A2").Resize(Rows.Count - 2, 100).ClearContents
DoEvents
Application.ScreenUpdating = False
End Sub
Con questo nuovo codice se il numero di colonne di dati prodotti e' superiore a 12 (cosa che succede gia' con le sestine) la macro crea file intermedi chiamati NomeIniziale_001, NomeIniziale_002 etc, ognuno di circa 70MB, prima di riprendere da colonna 1. L' ULTIMO BLOCCO, quello visibile al termine della macro,
non e' ancora salvato, devi provvedere manualmente se la cosa serve.
Ciao
Registrazione
