Pipe Delimit Selected Cells

[drmingle]

I want to be able to have this code work with any selection within a worksheet, currently it starts at "A1".

I thought I could fix it with the following:

Set rngLastCell = Selection. _

Currently it works, but targets at "A1" rather than the selection.

Any help would be appreciated...

'---------------------------------------------------------------------------------------
' Procedure : SaveAsPipeDelimited
' Author    : ###
' Date      : 10/29/2012
' Purpose   : To place "|" in between cells that are selected for easy data import.
'---------------------------------------------------------------------------------------
'
Sub SaveAsPipeDelimited()
    Dim vFileName As Variant
    Dim rngLastCell As Range
    Dim lLastRow As Long
    Dim nLastCol As Integer
    Dim lCurrRow As Long
    Dim nCurrCol As Integer
    Dim sRowString As String


   On Error GoTo SaveAsPipeDelimited_Error

    vFileName = Application.GetSaveAsFilename(filefilter:= _
     "Text Files (*.txt), .txt")
    If vFileName <> False Then
        Open vFileName For Output As #1
        Set rngLastCell = Selection. _
         SpecialCells(xlLastCell)
        lLastRow = rngLastCell.Row
        nLastCol = rngLastCell.Column
        For lCurrRow = 1 To lLastRow
            sRowString = ActiveSheet.Cells(lCurrRow, 1).Formula
            For nCurrCol = 2 To nLastCol
                sRowString = sRowString & "|" & ActiveSheet _
                .Cells(lCurrRow, nCurrCol).Formula
            Next nCurrCol
            If Len(sRowString) = nLastCol - 1 Then
                '/ print blank line only
                Print #1,
            Else
                Print #1, sRowString
            End If
        Next lCurrRow
        Close #1
    End If

   On Error GoTo 0
   Exit Sub

SaveAsPipeDelimited_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SaveAsPipeDelimited of Module Module1"
End Sub

 

[Fazza]

something like ..

Dim vFileName As Variant
Dim lCurrRow As Long
Dim nCurrCol As Integer
Dim sRowString As String

vFileName = Application.GetSaveAsFilename(filefilter:="Text Files (*.txt), .txt")

If vFileName <> False Then

  Open vFileName For Output As #1

    For lCurrRow = 1 To Selection.Rows.Count
      
      sRowString = Selection.Cells(lCurrRow, 1).Formula
      For nCurrCol = 2 To Selection.Columns.Count
        sRowString = sRowString & "|" & Selection.Cells(lCurrRow, nCurrCol).Formula
      Next nCurrCol

      If Len(sRowString) = nCurrCol - 2 Then
        '/ print blank line only
        Print #1,
      Else
        Print #1, sRowString
      End If

    Next lCurrRow
  Close #1
End If

If you didn't specifically want the cell formulas, you might consider a different approach - using an array to save reading one cell at a time from the worksheet. hth

 

[drmingle]

Perfect solution