시트 만들기/이름 바꾸기 및 CSV로 내보내기

Question

나는 매일 업데이트되는 데이터 목록 인 "AllData"워크 시트에 있습니다.

이 시트 (Alldata)의 모든 20 개의 행을 새 시트로 복사하고 필요에 따라 "1", "2", "3"...을 연속적으로 이름을 지정하고 만든 시트를 모두 CSV로 새로운 통합 문서.

(예 : 'Alldata'시트에는 103 개의 행이 포함되어 있으며 코드는 20, 20, 20, 20, 20 및 20을 각각 포함하는 1, 2, 3, 4, 5 및 6이라는 6 개의 새 시트를 만들어야합니다. 3 행은 ALLDATA 시트에서 복사 어떻게이 작업을 수행 할 수 있습니다

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

사용하여 새 시트를 만드는 :

를

그리고 수출 함수를 호출하기위한 절차 아래 885,453,210 :

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