I want to automate excel work of copying records up to 10,000 each and save into csv file

Question

I have an excel file of 50,000 records with column names (EmailID, FirstName and Checksum). I am copying 10,000 records from it and saving in a csv file. I do this to manually create 5 csv files, ie I split the 50,000 records into 10,000 each.

I want to do autoamate this work. I want to write a macro which will create csv files in a particular location.

use this as a starting point. http://stackoverflow.com/a/427646/624829 — Zeugma, May 28 '12 at 09:33

Ekkehard.Horner · Answer 1 · 2012-05-29T21:26:30.343

If you are lucky, your data look like this:

enter image description here

and you don't need fancy formatting in the .CSVs, you may get away with using .GetString(, cnStep, ...) on the recordset and some RegExps to fix the quotes, as examplified by this proof of concept script:

' want-to-automate-excel-work-of-copying-records-upto-10000-each-and-save-into-csv

Option Explicit

Const adClipString = 2
Const cnStep       = 3

Dim goFS : Set goFS = CreateObject( "Scripting.FileSystemObject" )

WScript.Quit demoMain()

Function demoMain()
  demoMain = 0 ' assume success

  Dim reClean : Set reClean = New RegExp
  reClean.Global    = True
  reClean.Multiline = True
  reClean.Pattern   = """(\d+)$"
  Dim reQuote : Set reQuote = New RegExp
  reQuote.Global    = True
  reQuote.Multiline = True
  reQuote.Pattern   = "^(.)"
  Dim sDDir   : sDDir       = "..\Data\SplitToCsv"
  Dim sXFSpec : sXFSpec     = goFS.BuildPath(sDDir, "SplitToCsv.xls")
  Dim oXDb    : Set oXDb    = CreateObject("ADODB.Connection")
  ' based on: !! http://www.connectionstrings.com/excel
  oXDb.open Join(Array(     _
        "Provider=Microsoft.Jet.OLEDB.4.0" _
      , "Data Source=" & sXFSpec           _
      , "Extended Properties="""           _
          & Join(Array(     _
                "Excel 8.0" _
              , "HDR=Yes"   _
              , "IMEX=1"    _
            ), ";" )        _
          & """"            _
  ), ";")
  Dim oRs : Set oRs = oXDb.Execute("SELECT * FROM [Everybody]")
  Dim sFs : sFs     = getRsFNames(oRs)
  Dim nR  : nR      = 1
  Do Until oRs.EOF
     Dim s : s = reQuote.Replace( _
                      reClean.Replace( _
                           oRs.GetString(adClipString, cnStep, """,""", vbCrLf) _
                         , "$1" _
                      ) _
                    , """$1" _
                 )
     Dim f : f = goFS.BuildPath(sDDir, "R" & nR & "ff.csv")
     WScript.Echo f
     WScript.Echo s
     goFS.CreateTextFile(f, True).Write sFs & vbCrLf & s
     nR = nR + cnStep
  Loop

  oXDb.Close

  WScript.Echo goFS.OpenTextFile(f).ReadAll()
End Function ' demoMain

Function getRsFNames(oRs)
  ReDim a(oRs.Fields.Count - 1)
  Dim f
  For f = 0 To UBound(a)
      a(f) = """" & oRs.Fields(f).Name & """"
  Next
  getRsFNames = Join(a, ",")
End Function ' getRsFNames

output:

cscript 10780869.vbs
..\Data\SplitToCsv\R1ff.csv
"EM1","FN1",1
"EM2","FN2",2
"EM3","FN3",3

..\Data\SplitToCsv\R4ff.csv
"EM4","FN4",4
"EM5","FN5",5
"EM6","FN6",6

..\Data\SplitToCsv\R7ff.csv
"EM7","FN7",7

"EmailID","FirstName","Checksum"
"EM7","FN7",7

I tried to make it easy for you to tinker with the connection string; depending on your installation, you may have to change the version number and/or property names.

You may notice the "OpenOffice" in the picture - that's one advantage of this approach: it works even on computers without Excel.

P.S.: I wrote this answer, when the question was still tagged vbscript.

I want to automate excel work of copying records up to 10,000 each and save into csv file

1 Answers1