0

我正在寻找一个宏来获取一个多行的 excel 文件，并将工作表的行拆分为我们希望每张工作表包含的任意数量的行，包括原始行，这些行也应该复制到每张工作表中。简单来说，如果我有一个带有行的文件

1
2
3

然后该宏将行拆分为带有 .csv 文件的工作表，因此我们在上面得到一个 3 文件表单

file1   file2   file3
  1         1       1
            2       2
                    3

我希望你明白我搜索它但只能找到的点

Option Explicit

Sub SplitWorkbooksByNrows()
'Jerry Beaucaire,  2/28/2012
'Split all data sheets in a folder by a variable number or rows per sheet, optional titles
'assumes only one worksheet of data per workbook
Dim N As Long, rw As Long, LR As Long, Cnt As Long, Cols As String, Titles As Boolean
Dim srcPATH As String, destPATH As String, fNAME As String, wbDATA As Workbook, titleRNG As Range

srcPATH = "C:\Path\To\Source\Files\"            'remember the final \ in this string
destPATH = "C:\Path\To\Save\NewFiles\"          'remember the final \ in this string
                                                'determine how many rows per sheet to create
    N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
    If N = 0 Then Exit Sub                      'exit if user clicks CANCEL
                                                'Examples of usable ranges:  A:A    A:Z   C:E   F:F
    Cols = Application.InputBox("Enter the Range of columns to copy", "Columns", "A:Z", Type:=2)
    If Cols = "False" Then Exit Sub             'exit if user clicks CANCEL
                                                'prompt to repeat row1 titles on each created sheet
    If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
                "Titles?") = vbYes Then Titles = True

    Application.ScreenUpdating = False          'speed up macro execution
    Application.DisplayAlerts = False           'turn off system alert messages, use default answers
    fNAME = Dir(srcPATH & "*.xlsx")             'get first filename from srcPATH

    Do While Len(fNAME) > 0                     'exit loop when no more files found
        Set wbDATA = Workbooks.Open(srcPATH & fNAME)        'open found file
        With ActiveSheet
            LR = Intersect(.Range(Cols), .UsedRange).Rows.Count             'how many rows of data?
            If Titles Then Set titleRNG = Intersect(.Range(Cols), .Rows(1)) 'set title range, opt.
            For rw = 1 + ---Titles To LR Step N 'loop in groups of N rows
                Cnt = Cnt + 1                   'increment the sheet creation counter
                Sheets.Add                      'create the new sheet
                If Titles Then titleRNG.Copy Range("A1")    'optionally add the titles
                                                'copy N rows of data to new sheet
                Intersect(.Range("A" & rw).Resize(N).EntireRow, .Range(Cols)).Copy Range("A1").Offset(Titles)
                ActiveSheet.Columns.AutoFit     'cleanup
                ActiveSheet.Move                'move created sheet to new workbook
                                                'save with incremented filename in the destPATH
                ActiveWorkbook.SaveAs destPATH & "Datafile_" & Format(Cnt, "00000") & ".xlsx", xlNormal
                ActiveWorkbook.Close False      'close the created workbook
            Next rw                             'repeat with next set of rows
        End With
        wbDATA.Close False                      'close source data workbook

        fNAME = Dir                             'get next filename from the srcPATH
    Loop                                        'repeat for each found file

    Application.ScreenUpdating = True           'return to normal speed
    MsgBox "A total of " & Cnt & " data files were created."        'report
End Sub

参考https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/rows 这个宏在做什么

if we have these rows
    1
    2
    3

宏做这个

file1   file2   file3
  1         2       3

提供的代码完全符合我的要求，但前提是宏可以添加行。像这样。

file1   file2   file3
  1         1       1
            2       2
                    3
4

1 回答 1

1

这可能有助于您入门。您需要放置自己的范围引用和文件路径等。

Sub SplitAndSave()
    Dim rows As Long, rw As Long, myFolder As String, ws As Worksheet

    rows = Worksheets("Sheet1").Range("A1:A10").rows.Count
    myFolder = "C:\Users\Desktop\MyFolder\"
    Set ws = Worksheets("Sheet2")

    For rw = 1 To rows
        ws.Cells.ClearContents
        Range("A1:A" & rw).Copy Destination:=ws.Range("A1")
        ws.SaveAs myFolder & "file" & rw & ".csv", xlCSV
    Next rw
End Sub

这会将您的数据分成Range(A1:A10)十个单独.csv的文件，并将它们MyFolder放在桌面上的一个文件夹中。

于 2013-09-22T11:54:25.553 回答