Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

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

Posted on 2014-09-17
8
Medium Priority
?
1,791 Views
Last Modified: 2014-09-17
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
0
Comment
Question by:Mandy_
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 4
  • 3
8 Comments
 
LVL 35

Expert Comment

by:[ fanpages ]
ID: 40328202
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
 
LVL 40

Accepted Solution

by:
als315 earned 1400 total points
ID: 40328236
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
 
LVL 35

Expert Comment

by:[ fanpages ]
ID: 40328240
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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
LVL 2

Author Comment

by:Mandy_
ID: 40328264
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
 
LVL 35

Expert Comment

by:[ fanpages ]
ID: 40328289
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
 
LVL 2

Author Comment

by:Mandy_
ID: 40328357
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
 
LVL 35

Assisted Solution

by:[ fanpages ]
[ fanpages ] earned 600 total points
ID: 40328407
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
 
LVL 2

Author Closing Comment

by:Mandy_
ID: 40328472
Many thanks and respect . Great work!
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

705 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question