excel - 我想自动复制最多 10,000 条记录并保存到 csv 文件中的 excel 工作

Question

我有一个包含 50,000 条记录的 excel 文件，其中包含列名（EmailID、FirstName 和 Checksum）。我正在从中复制 10,000 条记录并保存在 csv 文件中。我这样做是为了手动创建 5 个 csv 文件，即将 50,000 条记录分成 10,000 条。

我想做自动化这项工作。我想编写一个宏，它将在特定位置创建 csv 文件。

Answer 1

如果幸运的话，您的数据如下所示：

并且您不需要在 .CSV 中进行花哨的格式设置，您可以在记录集上使用 .GetString(, cnStep, ...) 并使用一些正则表达式来修复引号，如概念证明脚本所示：

' 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

输出：

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

我试图让您轻松修改连接字符串；根据您的安装，您可能需要更改版本号和/或属性名称。

您可能会注意到图片中的“OpenOffice”——这是这种方法的一个优点：它甚至可以在没有 Excel 的计算机上工作。

PS：当问题仍被标记为 vbscript 时，我写了这个答案。