This should work, it will output one line per selected cell cells are numbered left to right and down, so selecting a single column should work.
In Excel 2000 you can have multiple selection ranges
if you have multiple selection ranges each range will
be processed independently in the order that it each was
selected:
i.e. A1:A5, A3:C3, C2:D5
If you do not want to incude cells that are blank or only
include spaces you can include your own test.
IF cell.text <> "" THEN ...
Option Explicit
Sub OneRowPerCell()
Dim newrange As Range
Dim cell As Range
Dim filename As Variant
Dim retVal As Variant
Dim suffix As String
suffix = ""
' Range("B:B").Select 'for testing, normally manually select a column/cells
Set newrange = Intersect(Selection, ActiveSheet.UsedRange)
filename = "c:\temp\myfile.txt"
filename = InputBox("Supply filename for HTML generated from " _
& "selected range", "Filename for myfile", filename)
If UCase(Right(filename, 4)) = ".HTM" Then suffix = "<br>"
Close #1
Open filename For Output As 1
For Each cell In newrange
Print #1, cell.Text & suffix
Next cell
Close #1
'------------------ view results --------------------------.
If UCase(Right(filename, 4)) = ".HTM" Then
retVal = Shell("C:\Program Files\Internet Explorer" _
& "\IEXPLORE.EXE " & filename, vbNormalFocus)
Else
retVal = Shell("NOTEPAD.EXE " & filename, vbNormalFocus)
End If
End Sub
Sub OneRowPerCellPerColumn()
Dim newrange As Range
Dim cell As Range
Dim filename As Variant
Dim retVal As Variant
Dim suffix As String
suffix = ""
Dim iCol As Long
Dim Col_id As String
Dim colRange As Range
For iCol = 1 To ActiveSheet.UsedRange.Columns.Count
Set newrange = Intersect(Cells.Columns(iCol), ActiveSheet.UsedRange)
Col_id = Left(Cells(1, iCol).Address(0, 0), _
Len(Cells(1, iCol).Address(0, 0)) - 1)
filename = "c:\temp\myfile_" & Col_id & ".txt"
If UCase(Right(filename, 4)) = ".HTM" Then suffix = "<br>"
Close #1 'standard practice, close before opening
Open filename For Output As 1
For Each cell In newrange 'newrange
If Trim(cell.Text) <> "" Then
Print #1, cell.Text & suffix
End If
Next cell
Close #1
Next iCol
End Sub
'Code to read file until finished Open "c:\temp\outdoor.csv" for input as #1 do while not eof(1) input #1,x loop closeuses the Line Input # statement to read a line from a sequential file and assign it to a variable.
Open "TESTFILE" For Output As #1 ' Open file for output. Write #1, "Hello World", 234 ' Write comma-delimited data. Write #1, ' Write blank line. MyDate = #February 12, 1969# : MyNull = Null Write #1, MyDate ; " is a date" Close #1 ' Close file.
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\testfile.txt", True)
a.WriteLine("This is a test.")
a.Close
copy part1.html +passlist.html +part3.html composite.html
Sub ReadCommaSepFile_NoReturns()
Dim myVar As Variant
Dim i As Long
Dim rw As Long
'Open the file for Input
Open "C:\Test1.TXT" For Input As #1
'Read each line of the text file into the list of variables
'until the end of the file is reached
i = 0
rw = 1
Do While Not (EOF(1))
Input #1, myVar
i = i + 1
If i = 4 Then
Cells(rw, i).Value = CDate(myVar)
Else
Cells(rw, i).Value = myVar
End If
If i = 6 Then
rw = rw + 1
i = 0
End If
Loop
'Close the file
Close 1
End Sub
For more information on Importing and Exporting Text files with your
own delimiters see
Chip Pearson's web pages on
export and import.
Sub Macro23()
dim retval as variant
ActiveWorkbook.SaveAs filename:="C:\temp\text.txt", _
FileFormat:=xlTextPrinter, CreateBackup:=False
'--- show results ----
retval = Shell("NOTEPAD.EXE " & _
"c:\temp\text.txt", vbNormalFocus)
End Sub
If the filename contains spaces, you will have to include it within double quotes. (start Runs a Windows program or an MS-DOS program.) E.g.,
From DOS:
start c:\copiedsite\dmcritchie\excel\excel.htm
start "c:\copiedsite\dmcritchie\excel\excel.htm"
start http://www.mvps.org/dmcritchie/excel/excel.htm
From DOS starting Excel with switches: (291288 - Startup Switches for Microsoft Excel (2002: 291288, 2000: 211481; 97: 159474)
(SAFE Mode, Re-register/Reregister Excel extensions) )
Excel.exe /r "C:\test\file.xls"
From VBA:
Shell "start ""s:\new projects\drawing.dwg"" "
Shell "start c:\copiedsite\dmcritchie\excel\excel.htm"
Shell "start ""c:\copiedsite\dmcritchie\excel\excel.htm"""
also look at GetObject in VBA help.
More VBA:
Dim pblnHelp As Boolean
pblnHelp = Shell("start " & " """ & _
ActiveWorkbook.path & "\help.pdf"" ", vbMaximizedFocus)
Worksheet Solution, thanks to Scott Rubin
=HYPERLINK("help.pdf","Help and usage information")
Change directory or folder. ChDir Change the drive. ChDrive Copy a file. FileCopy Make directory or folder. MkDir Remove directory or folder. RmDir Rename a file, directory, or folder. Name Return current path. CurDir Return file date/time stamp. FileDateTime Return file, directory, label attributes. GetAttr Return file length. FileLen Return file name or volume label. Dir Set attribute information for a file. SetAttr
Visit [my Excel home page] [Index page] [Excel Onsite Search] [top of this page]
Please send your comments concerning this web page to: David McRitchie send email comments
Copyright © 1997 - 2006, F. David McRitchie, All Rights Reserved