Question

我在工作表＆＃34; AllData＆＃34;中有一个每天更新的数据列表。

我想将此工作表（Alldata）中的每20行复制到一个新工作表中，将其命名为＆＃34; 1＆＃34;，＆＃34; 2＆＃34;，＆＃34; 3＆＃34;。 ..根据需要连续，然后将每个创建的工作表导出为CSV格式的新工作簿。

（示例：＆＃39; Alldata＆＃39;表包含103行，代码必须创建6个新表，名为1,2,3,4,5和6，分别包含20,20,20,20从Alldata表中复制，20行和3行。

如何做到这一点？

Answer 1

这会直接将范围转换为CSV文件：

Sub SaveRangeToCsvFiles()

    Dim FileName As String
    Dim Ws As Worksheet, Wb As Workbook
    Dim rngDB As Range
    Dim r As Long, c As Long
    Dim pathOut As String
    Dim i As Long, n As Long

    pathOut = ThisWorkbook.Path & "\"

    Set Ws = ActiveSheet 'Sheets("AllData")
    With Ws
        r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        For i = 1 To r Step 20
            n = n + 1
            If i + 20 > r Then
                Set rngDB = Range("a" & i).Resize(r - i + 1, c)
            Else
                Set rngDB = Range("a" & i).Resize(20, c)
            End If
            TransToCSV pathOut & n & ".csv", rngDB
        Next i
    End With
    MsgBox ("Files Saved Successfully")
End Sub

Sub TransToCSV(myfile As String, rng As Range)

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

    Set objStream = CreateObject("ADODB.Stream")
    vDB = rng

    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 myfile, 2
        .Close
    End With
    Set objStream = Nothing
End Sub

Answer 2

使用以下内容创建新工作表：

Private Sub CreateSheet()
    Dim ws As Worksheet
    Dim i As Integer
    For i = 1 To 6
        Set ws = ThisWorkbook.Sheets.Add(After:= _
                ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = CStr(i)
    Next i
End Sub 'CreateSheet

以下调用导出功能的程序：

Sub ExportCsV
Dim i As Integer
For i = 1 to 20
    CsvExportRange rngRange:=ThisWorkbook.Worksheets(CStr(i)).Range("A1:A20"), _
      strFileName:=ThisWorkbook.path & "Result" & CStr(i) & ".csv", _
      strCharset:="UTF-8", strSeparator:=",", strRowEnd:=vbCrLf, NVC:=False
Next i
End Sub 'ExportCsV

并使用以下导出CSV，使用字符串重新格式化添加功能。（注意：在上面的模块或调用适当的模块名称之前。）

Sub CsvExportRange(rngRange As Object, strFileName As String, strCharset, strSeparator As String, strRowEnd As String, NVC As Boolean) 'NVC: _
    Null Value Control (If cell contain Null value, suppose reached end of range), d: delimiter

    Dim rngRow As Range
    Dim objStream As Object
    Dim i, lngFR, lngLR As Long 'lngFR: First Row, lngLR: Last Row

    lngFR = rngRange.SpecialCells(xlCellTypeVisible).Rows(1).row - rngRange.Rows(1).row + 1
    lngLR = rngRange.End(xlDown).row - rngRange.Rows(1).row + 1

    Set objStream = CreateObject("ADODB.Stream")
    objStream.Type = 2
    objStream.Charset = strCharset
    objStream.Open

    For i = lngFR To lngLR
        If Not (rngRange.Rows(i).EntireRow.Hidden) Then
            If IIf(NVC, (Cells(i + rngRange.Rows(1).row - 1, _
                rngRange.SpecialCells(xlCellTypeVisible).Columns(1).column).Value = vbNullString), False) Then Exit For
            objStream.WriteText CsvFormatRow(rngRange.Rows(i), strSeparator, strRowEnd)
        End If
    Next i

    objStream.SaveToFile strFileName, 2
    objStream.Close
End Sub 'CsvExportRange

Function CsvFormatRow(rngRow As Variant, strSeparator As String, strRowEnd As String) As String

    Dim arrCsvRow() As String

    ReDim arrCsvRow(rngRow.SpecialCells(xlCellTypeVisible).Cells.Count - 1)
    Dim rngCell As Range
    Dim lngIndex As Long

    lngIndex = 0

    For Each rngCell In rngRow.SpecialCells(xlCellTypeVisible).Cells
        arrCsvRow(lngIndex) = CsvFormatString(rngCell.Value, strSeparator)
        lngIndex = lngIndex + 1
    Next rngCell

    CsvFormatRow = Join(arrCsvRow, strSeparator) & strRowEnd
End Function 'CsvFormatRow

Function CsvFormatString(strRaw, strSeparator As String) As String

    Dim boolNeedsDelimiting As Boolean

    Dim strDelimiter, strDelimiterEscaped As String

    strDelimiter = """"
    strDelimiterEscaped = strDelimiter & strDelimiter

    boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
        Or InStr(1, strRaw, chr(10)) > 0 _
        Or InStr(1, strRaw, strSeparator) > 0

    CsvFormatString = strRaw

    If boolNeedsDelimiting Then
        CsvFormatString = strDelimiter & _
            Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
            strDelimiter
    End If
End Function 'CsvFormatString

参考文献：

stackoverflow_Named Sheets

stackoverflow_CSV

创建/重命名工作表并将其导出为CSV

2 个答案: