Try something like this:
Sub Test()
Dim arr
Dim sh As Worksheet
Dim strFolder As String
Dim strFile As String
strFolder = "C:\"
For Each sh In ThisWorkbook.Worksheets
With sh
arr = Range(.Cells(1), .Cells(120, 1))
strFile = strFolder & sh.Name & ".par"
SaveArrayToText strFile, arr
End With
Next sh
End Sub
Sub SaveArrayToText(ByVal txtFile As String, _
ByRef arr As Variant, _
Optional ByVal LBRow As Long = -1, _
Optional ByVal UBRow As Long = -1, _
Optional ByVal LBCol As Long = -1, _
Optional ByVal UBCol As Long = -1, _
Optional ByRef fieldArr As Variant)
Dim r As Long
Dim c As Long
Dim hFile As Long
If LBRow = -1 Then
LBRow = LBound(arr, 1)
End If
If UBRow = -1 Then
UBRow = UBound(arr, 1)
End If
If LBCol = -1 Then
LBCol = LBound(arr, 2)
End If
If UBCol = -1 Then
UBCol = UBound(arr, 2)
End If
hFile = FreeFile
'Close before reopening in another mode.
'---------------------------------------
On Error Resume Next
Open txtFile For Input As #hFile
Close #hFile
Open txtFile For Output As #hFile
If IsMissing(fieldArr) Then
For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next c
Next r
Else
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next c
For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next c
Next r
End If
Close #hFile
End Sub
RBS