Excel VBA Macro export worksheet to ;-separated CSV to user desktop

Hi Mandy,

I have attached a workbook containing the following code:

Option Explicit

Private Declare Sub CoTaskMemFree _
                Lib "ole32.dll" _
             (ByVal pvoid As Long)

Private Declare Function SHGetPathFromIDList _
                     Lib "shell32.dll" _
                   Alias "SHGetPathFromIDListA" _
                   (ByVal Pidl As Long, _
                    ByVal pszPath As String) As Long

Private Declare Function SHGetSpecialFolderLocation _
                     Lib "shell32.dll" _
                  (ByVal hWnd As Long, _
                   ByVal nFolder As Long, _
                   ByRef ppidl As Long) As Long
Private Function strSpecial_Folder(ByVal lngFolder As Long) As String
  
' --------------------------------------------------------------------------------------------------------------
' [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28140660.html ]
' --------------------------------------------------------------------------------------------------------------
  
  Dim lngPidl                                           As Long
  Dim lngPidlFound                                      As Long
  Dim strPath                                           As String
  Dim strReturn                                         As String
  
  On Error GoTo Err_strSpecial_Folder
  
  Const MAX_PATH                                        As Long = 260&
  
  strReturn = ""
  strPath = Space(MAX_PATH)
  
  lngPidlFound = SHGetSpecialFolderLocation(0&, lngFolder, lngPidl)

  If lngPidlFound = 0& Then
     If (SHGetPathFromIDList(lngPidl, strPath)) Then
        strReturn = Left$(strPath, InStr(1&, strPath, vbNullChar) - 1&)
    End If ' If (SHGetPathFromIDList(lngPidl, strPath)) Then
  End If ' If lngPidlFound = 0& Then
  
Exit_strSpecial_Folder:

  On Error Resume Next
  
  If lngPidl <> 0& Then
     Call CoTaskMemFree(lngPidl)
  End If ' If lngPidl <> 0& Then
  
  strSpecial_Folder = strReturn
  
  Exit Function
  
Err_strSpecial_Folder:

  On Error Resume Next
  
  strReturn = ""
  
  Resume Exit_strSpecial_Folder
  
End Function
Public Sub Q_28520034()

  Dim hndFile                                           As Long
  Dim intColumn                                         As Integer
  Dim intLast_Column                                    As Integer
  Dim lngLast_Row                                       As Long
  Dim lngRow                                            As Long
  Dim strDesktop_Folder                                 As String
  Dim strOutput                                         As String
  
  strDesktop_Folder = strSpecial_Folder(&H10)

  intLast_Column = Worksheets("Export").UsedRange.Column - 1 + Worksheets("Export").UsedRange.Columns.Count
  lngLast_Row = Worksheets("Export").UsedRange.Rows(Worksheets("Export").UsedRange.Rows.Count).Row

  hndFile = FreeFile
  
  Open strDesktop_Folder & "\export.csv" For Output As #hndFile

  For lngRow = 1& To lngLast_Row
  
      strOutput = ""
    
      For intColumn = 1 To intLast_Column
          strOutput = strOutput & Worksheets("Export").Cells(lngRow, intColumn).Value & ";"
      Next intColumn
      
      Print #1, Left$(strOutput, Len(strOutput) - 1)
      
  Next lngRow

  Close #hndFile
    
End Sub

Select allOpen in new window

A row from your example data is also missing an entry for the "Version" column:
S12345;JONES, MIKE;GUL;TEST;I;2431175;O157658;S;2013-05-17 12:50:11;New;PMAL;mike.jones@gul.com

That is...
S12345;JONES, MIKE;GUL;TEST;I;2431175;O157658;S;2013-05-17 12:50:11;New;<MISSING>;PMAL;mike.jones@gul.com

Also, I believe the contents of the "export.csv" file should actually be as follows:
---
UserId;Name;Comp;LOC;ET;IdentNo;ANo;IF;Date;Action;Product;Version;SMTP;SMTP2
S12345;JONES, MIKE;GUL;TEST;I;2431102;O157658;S;17/05/2013 11:52:33;Delete;PMAl;MS;mike.jones@gul.com;
S12345;JONES, MIKE;GUL;TEST;I;2431175;O157658;S;17/05/2013 12:50:11;New;PMAL;;mike.jones@gul.com;
S12345;JONES, MIKE;GUL;TEST;I;2431192;O157658;S;17/05/2013 13:08:33;Delete;PMAL;MS;mike.jones@gul.com;
S12345;JONES, MIKE;GUL;TEST;I;2431193;O157658;S;17/05/2013 13:08:33;Delete;PMAL;MS;;mike.jones@gul.com
---

That is the first three rows of data do end with a semi-colon because of the absence of the "SMTP2" column data for those rows.
Q-28520034.xls
export.csv

Sorry... I was mid-editing my comment when the other expert (als315) posted so the edit process failed.

Please find attached an updated workbook will a small amendment.
Q-28520034.xls

dear fanpages,

thanks for your help. I'm sorry but its still not running. this code below has to be switch to 64bit code. Declare should be mark with ptr_save attribut.

Private Declare Sub CoTaskMemFree _
                Lib "ole32.dll" _
             (ByVal pvoid As Long)

Private Declare Function SHGetPathFromIDList _
                     Lib "shell32.dll" _
                   Alias "SHGetPathFromIDListA" _
                   (ByVal Pidl As Long, _
                    ByVal pszPath As String) As Long

Private Declare Function SHGetSpecialFolderLocation _
                     Lib "shell32.dll" _
                  (ByVal hWnd As Long, _
                   ByVal nFolder As Long, _
                   ByRef ppidl As Long) As Long

Select allOpen in new window

Hi Mandy,

Sorry (again), I was not aware you required 64-bit compliant code.

Please disregard my input.  I will not be able to progress with the necessary changes.

I suggest you continue with als315's contribution in preference to my own.

dear als315,

your code working fine so far. Would it still possible to remove the spaces? For example sometimes i have data in row 2 to 30 and 151 to 180 and 186 to 220. The empty rows, the spaces between, should be removed. Thanks in advance.

Many thanks and respect . Great work!