[英]Excel: macro to export worksheet as CSV file without leaving my current Excel sheet
There are a lot of questions here to create a macro to save a worksheet as a CSV file.这里有很多问题要创建一个宏来将工作表保存为 CSV 文件。 All the answers use the SaveAs, likethis one from SuperUser.所有答案都使用 SaveAs,就像 SuperUser 的这个答案一样。 They basically say to create a VBA function like this:他们基本上说要创建一个这样的 VBA 函数:
Sub SaveAsCSV()
ActiveWorkbook.SaveAs FileFormat:=clCSV, CreateBackup:=False
End Sub
This is a great answer, but I want to do an export instead of Save As .这是一个很好的答案,但我想做一个export 而不是 Save As 。 When the SaveAs is executed it causes me two annoyances:当 SaveAs 被执行时,它给我带来了两个烦恼:
Is it possible to just export the current worksheet as a file, but to continue working in my original file?是否可以将当前工作表导出为文件,但继续在我的原始文件中工作?
@NathanClement was a bit faster. @NathanClement 有点快。 Yet, here is the complete code (slightly more elaborate):然而,这是完整的代码(稍微详细一点):
Option Explicit
Public Sub ExportWorksheetAndSaveAsCSV()
Dim wbkExport As Workbook
Dim shtToExport As Worksheet
Set shtToExport = ThisWorkbook.Worksheets("Sheet1") 'Sheet to export as CSV
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False 'Possibly overwrite without asking
wbkExport.SaveAs Filename:="C:\tmp\test.csv", FileFormat:=xlCSV
Application.DisplayAlerts = True
wbkExport.Close SaveChanges:=False
End Sub
Almost what I wanted @Ralph, but here is the best answer , because it solves some annoyances in your code:几乎是我想要的@Ralph,但这是最好的答案,因为它解决了代码中的一些烦恼:
To solve these problems , and meet all my requirements, I've adapted the code from here .为了解决这些问题并满足我的所有要求,我从这里改编了代码。 I've cleaned it a little to make it more readable.我已经对其进行了一些清理以使其更具可读性。
Option Explicit
Sub ExportAsCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Dim Change below to "- 4" to become compatible with .xls files
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Note some characteristics of the code above:注意上面代码的一些特征:
- 5
to - 4
when setting MyFileName in the code above.对于 3 个字符的文件扩展名,在上面的代码中设置 MyFileName 时,必须将- 5
更改为- 4
。 Edit: put Local:=True
to save with my locale CSV delimiter.编辑:把Local:=True
用我的语言环境 CSV 分隔符保存。
As per my comment on @neves post, I slightly improved this by adding the xlPasteFormats as well as values part so dates go across as dates - I mostly save as CSV for bank statements, so needed dates.根据我对@neves 帖子的评论,我通过添加 xlPasteFormats 和值部分稍微改进了这一点,因此日期作为日期进行 - 我主要将银行对帐单保存为 CSV,因此需要日期。
Sub ExportAsCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
'Dim Change below to "- 4" to become compatible with .xls files
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Here is a slight improvement on the this answer above taking care of both .xlsx and .xls files in the same routine, in case it helps someone!这是对上面这个答案的轻微改进,在同一个例程中处理 .xlsx 和 .xls 文件,以防它帮助某人!
I also add a line to choose to save with the active sheet name instead of the workbook, which is most practical for me often:我还添加了一行以选择使用活动工作表名称而不是工作簿进行保存,这对我来说经常是最实用的:
Sub ExportAsCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, InStrRev(CurrentWB.Name, ".") - 1) & ".csv"
'Optionally, comment previous line and uncomment next one to save as the current sheet name
'MyFileName = CurrentWB.Path & "\" & CurrentWB.ActiveSheet.Name & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
For those situations where you need a bit more customisation of the output (separator or decimal symbol), or who have large dataset (over 65k rows), I wrote the following:对于需要更多自定义输出(分隔符或十进制符号)或拥有大型数据集(超过 65k 行)的情况,我编写了以下内容:
Option Explicit
Sub rng2csv(rng As Range, fileName As String, Optional sep As String = ";", Optional decimalSign As String)
'export range data to a CSV file, allowing to chose the separator and decimal symbol
'can export using rng number formatting!
'by Patrick Honorez --- www.idevlop.com
Dim f As Integer, i As Long, c As Long, r
Dim ar, rowAr, sOut As String
Dim replaceDecimal As Boolean, oldDec As String
Dim a As Application: Set a = Application
ar = rng
f = FreeFile()
Open fileName For Output As #f
oldDec = Format(0, ".") 'current client's decimal symbol
replaceDecimal = (decimalSign <> "") And (decimalSign <> oldDec)
For Each r In rng.Rows
rowAr = a.Transpose(a.Transpose(r.Value))
If replaceDecimal Then
For c = 1 To UBound(rowAr)
'use isnumber() to avoid cells with numbers formatted as strings
If a.IsNumber(rowAr(c)) Then
'uncomment the next 3 lines to export numbers using source number formatting
' If r.cells(1, c).NumberFormat <> "General" Then
' rowAr(c) = Format$(rowAr(c), r.cells(1, c).NumberFormat)
' End If
rowAr(c) = Replace(rowAr(c), oldDec, decimalSign, 1, 1)
End If
Next c
End If
sOut = Join(rowAr, sep)
Print #f, sOut
Next r
Close #f
End Sub
Sub export()
Debug.Print Now, "Start export"
rng2csv shOutput.Range("a1").CurrentRegion, RemoveExt(ThisWorkbook.FullName) & ".csv", ";", "."
Debug.Print Now, "Export done"
End Sub
wsToExport.Move
With Workbooks
Set wbCsv = .Item(.Count)
End With
Application.DisplayAlerts = False
wbCsv.SaveAs xlCSV
wbCsv.Close False
Application.DisplayAlerts = True
As I commented, there are a few places on this site that write the contents of a worksheet out to a CSV.正如我评论的那样,这个网站上有几个地方可以将工作表的内容写入 CSV。 This one and this one to point out just two. 这个和这个只指出两个。
Below is my version下面是我的版本
UsedRange
- because you want to get all of the contents in the worksheet它还使用UsedRange
- 因为您想获取工作表中的所有内容The code ...编码 ...
Sub makeCSV(theSheet As Worksheet)
Dim iFile As Long, myPath As String
Dim myArr() As Variant, outStr As String
Dim iLoop As Long, jLoop As Long
myPath = Application.ActiveWorkbook.Path
iFile = FreeFile
Open myPath & "\myCSV.csv" For Output Lock Write As #iFile
myArr = theSheet.UsedRange
For iLoop = LBound(myArr, 1) To UBound(myArr, 1)
outStr = ""
For jLoop = LBound(myArr, 2) To UBound(myArr, 2) - 1
If InStr(1, myArr(iLoop, jLoop), ",") Then
outStr = outStr & """" & myArr(iLoop, jLoop) & """" & ","
Else
outStr = outStr & myArr(iLoop, jLoop) & ","
End If
Next jLoop
If InStr(1, myArr(iLoop, jLoop), ",") Then
outStr = outStr & """" & myArr(iLoop, UBound(myArr, 2)) & """"
Else
outStr = outStr & myArr(iLoop, UBound(myArr, 2))
End If
Print #iFile, outStr
Next iLoop
Close iFile
Erase myArr
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.