Solved

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

Posted on 2014-09-17
8
1,701 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_
  • 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 39

Accepted Solution

by:
als315 earned 350 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
 
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
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
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 150 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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
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 how to use longer labels with horizontal bar charts instead of the vertical column chart.

895 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

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now