Prova a vedere questo file:
https://www.dropbox.com/s/zjbk2ygnpqk6aim/FRED.xlsm?dl=0
nel modulo1 è presente una procedura nominata "TEST" che si appoggia ad altre funzioni (due sono di Norman Jones) per trovare l'ultima colonna, l'ultima riga di ogni intervallo e creare il file di testo.
I file txt vengono salvati nello stesso percorso dove si trova il file excel.
Ma volendo si potrebbe indicare un percorso diverso indicandolo in corrispondenza della variabile sPath.
Sub TEST()
Dim ws As Worksheet
Dim i As Long, y As Long
Dim iLastCol As Long, iLastRow, iTotalRows As Long
Dim sSymbol As String
Dim arrDate As Variant
Dim arrValue As Variant
Dim sTesto As String
Dim sPath As String
With ThisWorkbook
Set ws = .Worksheets(1)
sPath = .Path
If Right(sPath, 1) <> Application.PathSeparator Then
sPath = sPath & Application.PathSeparator
End If
End With
iLastCol = LastCol(ws, ws.UsedRange)
With ws
For i = 1 To iLastCol Step 2
iLastRow = LastRow(Cells(1).Parent, .Columns(i), 8)
iTotalRows = iLastRow - 7
sSymbol = .Cells(1, i).Value
arrDate = .Cells(8, i).Resize(iTotalRows).Value
arrValue = .Cells(8, i + 1).Resize(iTotalRows).Value
sTesto = "Symbol;Date;Value"
For y = 1 To iTotalRows
If IsError(arrValue(y, 1)) Then arrValue(y, 1) = "#N/D"
sTesto = sTesto & vbNewLine & sSymbol & ";" & arrDate(y, 1) & ";" & arrValue(y, 1)
Next y
Call ScriviFileTesto(sPath & sSymbol & ".txt", sTesto, True)
Next i
End With ' ws
End Sub
Public Function LastRow(sh As Worksheet, _
Optional Rng As Range, _
Optional minRow As Long = 1, _
Optional strPassword As String = "")
'by Norman David Jones
Dim bProtected As Boolean
With sh
If Rng Is Nothing Then
Set Rng = .Cells
End If
bProtected = .ProtectContents = True
If bProtected Then
.Unprotect Password:=strPassword
End If
End With
On Error Resume Next
LastRow = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
If LastRow < minRow Then
LastRow = minRow
End If
If bProtected Then
sh.Protect Password:=strPassword ', UserInterfaceOnly:=False
End If
End Function
Public Function LastCol(sh As Worksheet, _
Optional Rng As Range, _
Optional minCol As Long = 1, _
Optional strPassword As String = "")
'by Norman David Jones
Dim bProtected As Boolean
With sh
If Rng Is Nothing Then
Set Rng = .Cells
End If
bProtected = .ProtectContents = True
If bProtected Then
.Unprotect Password:=strPassword
End If
End With
On Error Resume Next
LastCol = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
If LastCol < minCol Then
LastCol = minCol
End If
If bProtected Then
sh.Protect Password:=strPassword ', UserInterfaceOnly:=False
End If
End Function
Sub ScriviFileTesto(sFileFullName As String, _
sCorpoTesto As String, _
Optional bSovrascrivi As Boolean = True)
Dim Fso As Object, File As Object
Dim iMode As Long
If sFileFullName = vbNullString Then Exit Sub
Set Fso = CreateObject("Scripting.FileSystemObject")
If bSovrascrivi Then
iMode = 2
Else
iMode = 8
End If
With Fso
With .OpenTextFile(sFileFullName, iMode, True)
If bSovrascrivi Then
.Write sCorpoTesto
Else
.WriteLine sCorpoTesto
End If
.Close
End With
End With 'Fso
Set Fso = Nothing
End Sub