Question

我有一个可以将工作表导出到.csv的工作簿，但它会将其复制到一个新的工作簿中一秒钟，然后保存我想知道是否有办法只是从工作表中复制数据而不打开新的工作簿？我的代码是：

        Sub CopyToCSV()

        Dim FlSv As Variant
        Dim MyFile As String
        Dim sh As Worksheet
        Dim MyFileName As String
        Dim DateString As String

Application.ScreenUpdating = False

        DateString = Format(Now(), "dd-mm-yyyy_hh-mm-ss-AM/PM") '<~~ uses current time from computer clock down to the second
        MyFileName = "Results - " & DateString

        Set sh = Sheets("Sheet1")
        sh.Copy
        FlSv = Application.GetSaveAsFilename(MyFileName, fileFilter:="CSV (Comma delimited) (*.csv), *.csv", Title:="Where should we save this?")

     If FlSv = False Then GoTo UserCancel Else GoTo UserOK

UserCancel:             '<~~ this code is run if the user cancels out the file save dialog
        ActiveWorkbook.Close (False)
        MsgBox "Export Canceled"
        Exit Sub

UserOK:                 '<~~ this code is run if user proceeds with saving the file (clicks the OK button)
        MyFile = FlSv
        With ActiveWorkbook
            .SaveAs (MyFile), FileFormat:=xlCSV, CreateBackup:=False
            .Close False
        End With

        Application.DisplayAlerts = True
        Application.ScreenUpdating = True

    End Sub

Answer 1

尝试此操作（在简单数据集上测试）

Private Sub ExportToCsv()
    Dim ws As Worksheet
    Dim delim As String, LastCol As String, csvFile As String, CsvLine As String
    Dim aCell As Range, DataRange As Range
    Dim ff As Long, lRow As Long, lCol As Long
    Dim i As Long, j As Long

    '~~> We use "," as delimiter
    delim = ","

    '~~> Change this to specify your file name and path
    csvFile = "C:\Users\Siddharth\Desktop\Sample.Csv"

    '~~> Change this to the sheet which you want to export as csv
    Set ws = ThisWorkbook.Sheets("Sheet9")

    With ws
        '~~> Find last row and last column
        lRow = .Cells.Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row

        lCol = .Cells.Find(What:="*", _
                After:=.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column

        '~~> Column number to column letter
        LastCol = Split(Cells(, lCol).Address, "$")(1)

        '~~> This is the range which will be exported
        Set DataRange = .Range("A1:" & LastCol & lCol)

        '
        '~~> Loop through cells in the range and write to text file
        '

        ff = FreeFile

        Open csvFile For Output As #ff

        For i = 1 To lRow
            For j = 1 To lCol
                CsvLine = CsvLine & (delim & Replace(.Cells(i, j).Value, """", """"""""))
            Next j

            Print #ff, Mid(CsvLine, 2)

            CsvLine = ""
        Next

        '~~> Close text file
        Close #ff
    End With
End Sub

Answer 2

Sub CopyToCSV()

        Dim FlSv As Variant
        Dim MyFile As String
        Dim sh As Worksheet
        Dim MyFileName As String
        Dim strTxt As String

        Dim vDB, vR() As String, vTxt()
        Dim i As Long, n As Long, j As Integer
        Dim objStream
        Dim strFile As String

Application.ScreenUpdating = False

        DateString = Format(Now(), "dd-mm-yyyy_hh-mm-ss-AM/PM") '<~~ uses current time from computer clock down to the second
        MyFileName = "Results - " & DateString

        FlSv = Application.GetSaveAsFilename(MyFileName, fileFilter:="CSV (Comma delimited) (*.csv), *.csv", Title:="Where should we save this?")

     If FlSv = False Then GoTo UserCancel Else GoTo UserOK

UserCancel:             '<~~ this code is run if the user cancels out the file save dialog
        ActiveWorkbook.Close (False)
        MsgBox "Export Canceled"
        Exit Sub

UserOK:                 '<~~ this code is run if user proceeds with saving the file (clicks the OK button)

    Set objStream = CreateObject("ADODB.Stream")
    MyFile = FlSv
    vDB = ActiveSheet.UsedRange
    For i = 1 To UBound(vDB, 1)
        n = n + 1
        ReDim vR(1 To UBound(vDB, 2))
        For j = 1 To UBound(vDB, 2)
            vR(j) = vDB(i, j)
        Next j
        ReDim Preserve vTxt(1 To n)
        vTxt(n) = Join(vR, ",")
    Next i
    strtxt = Join(vTxt, vbCrLf)
    With objStream
        .Charset = "utf-8"
        .Open
        .WriteText strtxt
        .SaveToFile FlSv, 2
        .Close
    End With
    Set objStream = Nothing

        Application.DisplayAlerts = True
        Application.ScreenUpdating = True

End Sub

有没有办法导出和Excel工作表而不复制到工作簿？

2 个答案: