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

Dear expert,

i'm looking for a macro, export a worksheet called "export" into a semicolon separated CSV file
to User desktop  

Pls see example and attachment

i've found this example. I think still needs to be adjusted a little ???
1. where the file is to be saved  (user desktop)
2.Only the worksheet export should be saved


Option Explicit
Sub export2csv()
    Dim lastColumn As Integer
    Dim lastRow As Integer
    Dim strString As String
    Dim i As Integer, j As Integer

    lastColumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
    lastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row

    Open "export.csv" For Output As #1

    For i = 1 To lastRow
        Cells(i, 1).Select
        strString = ""
        For j = 1 To lastColumn
            If j <> lastColumn Then
                strString = strString & Cells(i, j).Value & ";" ' Use semicolon instead of pipe.
            Else
                strString = strString & Cells(i, j).Value
            End If
        Next j
        Print #1, strString
    Next i

    Close #1
End Sub

Open in new window



UserId;Name;Comp;LOC;ET;IdentNo;ANo;IF;Date;Action;Product;Version;SMTP;SMTP2
S12345;JONES, MIKE;GUL;TEST;I;2431102;O157658;S;2013-05-17 11:52:33;Delete;PMAl;MS;mike.jones@gul.com
S12345;JONES, MIKE;GUL;TEST;I;2431175;O157658;S;2013-05-17 12:50:11;New;PMAL;mike.jones@gul.com
S12345;JONES, MIKE;GUL;TEST;I;2431192;O157658;S;2013-05-17 13:08:33;Delete;PMAL;MS;mike.jones@gul.com
S12345;JONES, MIKE;GUL;TEST;I;2431193;O157658;S;2013-05-17 13:08:33;Delete;PMAL;MS;;mike.jones@gul.com

Thank you so much for your help!!!
Mandy
Export.csv
LVL 2
Mandy_Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

[ fanpages ]IT Services ConsultantCommented:
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

Open 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
0
als315Commented:
Will be better if you upload source file
You can find desktop folder with this code:
Dim UD as String
UD =  CreateObject("WScript.Shell").specialfolders("Desktop")
UD = UD & "\export.csv"
Open UD For Output As #1

Open in new window

In your sample Activeworksheet is exported, change it to EXPORT
whole code:
Sub export2csv()
    Dim lastColumn As Integer
    Dim lastRow As Integer
    Dim strString As String
    Dim i As Integer, j As Integer
    Dim UD As String
    
    UD = CreateObject("WScript.Shell").specialfolders("Desktop")
    UD = UD & "\export.csv"
    Worksheets("EXPORT").Activate
    lastColumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
    lastRow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row

    Open UD For Output As #1

    For i = 1 To lastRow
        Cells(i, 1).Select
        strString = ""
        For j = 1 To lastColumn
            If j <> lastColumn Then
                strString = strString & Cells(i, j).Value & ";" ' Use semicolon instead of pipe.
            Else
                strString = strString & Cells(i, j).Value
            End If
        Next j
        Print #1, strString
    Next i

    Close #1
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
[ fanpages ]IT Services ConsultantCommented:
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
0
Cloud Class® Course: Python 3 Fundamentals

This course will teach participants about installing and configuring Python, syntax, importing, statements, types, strings, booleans, files, lists, tuples, comprehensions, functions, and classes.

Mandy_Author Commented:
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

Open in new window

0
[ fanpages ]IT Services ConsultantCommented:
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.
0
Mandy_Author Commented:
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.
0
[ fanpages ]IT Services ConsultantCommented:
Hi Mandy,

To address your issue with empty rows, I would change this line:

Print #1, strString

To read like this:

If Len(Trim$(Replace(strString, ";", ""))) > 0 Then
   Print #1, strString
End If


I have attached a new version of my workbook, using als315's method of obtaining the User's Desktop folder.

This version should run within your 64-bit based environment.
Q-28520034.xls
export.csv
0
Mandy_Author Commented:
Many thanks and respect . Great work!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.