PDA

View Full Version : [SOLVED] Excel Select the Rows - Input Box - Save to Text Files



dj44
05-06-2017, 07:33 AM
Folks,:)

Good Saturday.

I wanted to save a selection to text files.

So I use the input box select my rows and it should save them to my text files on my desktop.

So i did some stuff and well - its not happening

Please can a pro help me see why my range doesnt work






Sub SaveSelectedRows()


Dim i As Long
Dim LastDataRow As Long
Dim MyFile As String
Dim fnum


Dim UserRange As Range
'On Error GoTo Canceled
Set UserRange = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Type:=8)



'LastDataRow = ActiveSheet.Range(UserRange)

'LastDataRow = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row

For i = 4 To LastDataRow


'-- Text Files Names : Column E

'MyFile = "C:\Users\DJ-PC\Desktop\Text\" & ActiveSheet.Range("E" & i).Value & ".txt"

MyFile = "C:\Users\DJ-PC\Desktop\Text\" & ActiveSheet.Range(UserRange).Value & ".txt"


'-- Save Text in Column 10 Cells
s = NewLn(Cells(i, 10).text) & vbNewLine


fnum = FreeFile
Open MyFile For Output As fnum
Print #fnum, s
Close fnum
Next i

End Sub



Private Function NewLn(s As String) As String
NewLn = Replace(s, vbLf, vbNewLine)

End Function




it works normally - but i wanted to use a input box becuase i have to keep changing the code when i need different rows only

Thank you for the help

SamT
05-06-2017, 09:18 AM
There's a couple of ways I would do it, and they both need the selection made before the sub (Macro) is run.

Sub SaveSelectedRows()
'Select only Cells in Column "J"
Dim Cel As Range

MyFile = "C:\Users\DJ-PC\Desktop\Text\" & ActiveSheet.Range(UserRange).Value & ".txt"

For Each Cel In Selection
'-- Save Text in Column 10 Cells
s = NewLn(Cel) & vbNewLine

fnum = FreeFile
Open MyFile For Output As fnum
Print #fnum, s
Close fnum
Next Cel

End Sub


Sub SaveSelectedRows()
'Select Entire Rows
Dim Cel As Range

MyFile = "C:\Users\DJ-PC\Desktop\Text\" & ActiveSheet.Range(UserRange).Value & ".txt"

For Each Cel In Selection.Columns(10)
'-- Save Text in Column 10 Cells
s = NewLn(Cel) & vbNewLine

fnum = FreeFile
Open MyFile For Output As fnum
Print #fnum, s
Close fnum
Next Cel

End Sub

To do it with a reminder to select something after running the Macro will require two new subs in addition to one of the above, and changing the name of that one. OK, I combined both the above subs for more flexibility.

Option Explicit

SaveTextEnabled As Boolean

Sub SaveSelectedRows()
MsgBox "PLease Select the Rows or cells to save"
SaveTextEnabled = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If SaveTextEnabled Then SaveTexts
End Sub
Sub SaveTexts()
'Select Entire Rows or select Column "J"

SaveTextEnabled = False

Dim Texts As Range
Dim Cel As Range

MyFile = "C:\Users\DJ-PC\Desktop\Text\" & ActiveSheet.Range(UserRange).Value & ".txt"

If Selection.Columns.Count > 1 Then
Set Texts = Intersect(Selection, Columns(10))
Else
Set Texts = Selection
End If

For Each Cel In Texts
s = NewLn(Cel) & vbNewLine

fnum = FreeFile
Open MyFile For Output As fnum
Print #fnum, s
Close fnum
Next Cel

End Sub

rlv
05-06-2017, 10:58 AM
The original code has some fixed assumptions about the data

1) The file names will always be in column "E"
2) The data to be written will always be in column "J" ( i.e. col 10)
3) The file name is on the same row as the data to be written.

If you are planning on keeping those basic assuptions then this should work.


Sub SaveSelectedRows()
Dim i As Long, LastDataRow As Long, StartRowNum As Long, EndRowNum As Long
Dim MyFile As String
Dim fnum, s
Dim UserRange As Range

'On Error GoTo Canceled
Set UserRange = Application.InputBox(Prompt:="Please Select Range", Title:="Range Select", Type:=8)

With UserRange
StartRowNum = .Cells(1, 1).Row
EndRowNum = .Cells(.Rows.Count).Row
End With

LastDataRow = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row

If EndRowNum < LastDataRow Then
LastDataRow = EndRowNum
End If

For i = StartRowNum To LastDataRow

'-- Text Files Names : Column E
MyFile = "C:\Users\DJ-PC\Desktop\Text\" & ActiveSheet.Range("E" & i).Value & ".txt"

'-- Save Text in Column 10 (Column J) Cells
s = NewLn(Cells(i, 10).Text) & vbNewLine

fnum = FreeFile
Open MyFile For Output As fnum
Print #fnum, s
Close fnum
Next i
End Sub


If you want to change those restrictions, for example, specifying another column for filenames, then you'll need to explain more about how you want to change things.

dj44
05-06-2017, 12:23 PM
Thank you very much Sam and rlv, it has worked a particular treat!

i am working on using input boxes becuase one time i ended up with 20 scripts for the same macro and that was a bit of a night mare.

So the input box is very useful to me

However onto another inexplicable problem has popped up out of memory i only had 2 sheets in my workbook - better delete some of my handy macros as per my coding style not the most efficient - i cluttered it all up trying to solve this problem :grinhalo:


thank you for the code and great explanations folks and enjoy the great weekend
:beerchug: