将行从一张纸复制到六张纸

Question

我有一个电子表格，每天会有不同的行数。
我试图将该行数除以 6，然后将信息复制到同一个工作簿中的六个不同工作表中。

例如——假设原始工作表有 3000 行。 3000 行除以 6 (500)，复制到六个不同的工作表中，或者可能有 2475 行，现在将其除以 6 并尝试保持工作表之间拆分的记录数大致相同（保持工作表与原始 3000 或 2475行）在同一个工作簿中。

我有创建 6 个额外工作表的代码，但记录没有被复制到这些工作表中。

Option Explicit

Public Sub CopyLines()
Dim firstRow As Long
Dim lastRow As Long
Dim i As Long
Dim index As Long
Dim strsheetName As String
Dim sourceSheet As Worksheet
Dim strWorkbookName As Workbook

Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add
Sheets.Add

Set sourceSheet = Workbooks(strWorkbookName).Worksheets(strsheetName)

firstRow = sourceSheet.UsedRange.Row
lastRow = sourceSheet.UsedRange.Rows.Count + firstRow - 1

index = 1

For i = firstRow To lastRow
    sourceSheet.Rows(i).Copy
    Select Case index Mod 6
    Case 0:
        strsheetName = "Sheet1"
    Case 1:
        strsheetName = "Sheet2"
    Case 2:
        strsheetName = "Sheet3"
    Case 3:
        strsheetName = "Sheet4"
    Case 4:
        strsheetName = "Sheet5"
    Case 5:
        strsheetName = "Sheet6"
    End Select

    Worksheets(strsheetName).Cells((index / 6) + 1, 1).Paste

    index = index + 1
Next i
End Sub

Answer 1

几件事：

1. 不要在一开始就创建工作表。如果需要，在循环中创建它们。这样，如果只有 3 行数据，您将不会得到空白表。循环创建它们。

2. 下面的代码还假设您事先没有Sheet1-6。否则你会在newSht.Name = "Sheet" & i得到一个错误

3. 避免使用UsedRange 来查找最后一行。你可能想看看Finding last used cell in Excel with VBA

代码：

我已经提交了代码。您理解代码应该没有问题，但如果您这样做了，那么只需回发即可。这是你正在尝试的吗？

Option Explicit

'~~> Set max sheets required
Const NumberOfSheetsRequired As Long = 6

Public Sub CopyLines()
    Dim wb As Workbook
    Dim ws As Worksheet, newSht As Worksheet
    Dim lastRow As Long
    Dim StartRow As Long, EndRow As Long
    Dim i As Long
    Dim NumberOfRecordToCopy As Long
    Dim strWorkbookName as String 
    
    '~~> Change the name as applicable
    strWorkbookName = "TMG JULY 2020 RENTAL.xlsx"
    Set wb = Workbooks(strWorkbookName)
    
    Set ws = wb.Sheets("MainSheet")
    
    With ws
        If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then
            '~~> Find last row
            lastRow = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        
            '~~> Get the number of records to copy
            NumberOfRecordToCopy = lastRow / NumberOfSheetsRequired
            
            '~~> Set your start and end row
            StartRow = 1
            EndRow = StartRow + NumberOfRecordToCopy
            
            '~~> Create relevant sheet
            For i = 1 To NumberOfSheetsRequired
                '~~> Add new sheet
                Set newSht = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
                newSht.Name = "Sheet" & i
                
                '~~> Copy the relevant rows
                ws.Range(StartRow & ":" & EndRow).Copy newSht.Rows(1)
                
                '~~> Set new start and end row
                StartRow = EndRow + 1
                EndRow = StartRow + NumberOfRecordToCopy
                
                '~~> If start row is greater than last row then exit loop.
                '~~> No point creating blank sheets
                If StartRow > lastRow Then Exit For
            Next i
        End If
    End With
    
    Application.CutCopyMode = False
End Sub

Answer 2

您的代码在对数据执行任何操作之前创建了 6 张工作表，这可能是一种浪费。 此外，一旦创建了这些工作表，就无法保证它们将具有名称Sheet1、Sheet2 等。这些名称可能已被使用。这就是为什么您应该在尝试创建目标工作表之前始终检查它们是否存在。

Option Explicit

Public Sub CopyLines()
    Dim firstRow As Long
    Dim lastRow As Long
    Dim i As Long
    Dim index As Long
    Dim strSheetName As String
    Dim sourceSheet As Worksheet
    Dim strWorkbookName As String
           
    'assume the current workbook is the starting point
    strWorkbookName = ActiveWorkbook.Name
    
    'assume that the first sheet contains all the rows
    strSheetName = ActiveWorkbook.Sheets(1).Name
        
    
    Set sourceSheet = Workbooks(strWorkbookName).Worksheets(strSheetName)
    
    firstRow = sourceSheet.UsedRange.Row
    lastRow = sourceSheet.UsedRange.Rows.Count + firstRow - 1
    
    index = 1
    
    For i = firstRow To lastRow
      sourceSheet.Rows(i).Copy
      Select Case index Mod 6
        Case 0:
          strSheetName = "Sheet1"
        Case 1:
          strSheetName = "Sheet2"
        Case 2:
          strSheetName = "Sheet3"
        Case 3:
          strSheetName = "Sheet4"
        Case 4:
          strSheetName = "Sheet5"
        Case 5:
          strSheetName = "Sheet6"
      End Select
      
      'check if the destination sheet exists
      If Not Evaluate("ISREF('" & strSheetName & "'!A1)") Then
        
        'if it does not, then create it
        Sheets.Add
        
        'and rename it to the proper destination name
        ActiveSheet.Name = strSheetName
        
      End If
      
      'now paste the copied cells using PasteSpecial
      Worksheets(strSheetName).Cells(Int(index / 6) + 1, 1).PasteSpecial
      
      'advance to the next row
      index = index + 1

      'prevent Excel from freezing up, by calling DoEvents to handle
      'screen redraw, mouse events, keyboard, etc.
      DoEvents
    Next i
End Sub

Answer 3

请尝试下一个代码。它使用数组和数组切片，它应该非常快：

Sub testSplitRowsOnSixSheets()
 Dim sh As Worksheet, lastRow As Long, lastCol As Long, arrRows As Variant, wb As Workbook
 Dim arr As Variant, slice As Variant, SplCount As Long, shNew As Worksheet
 Dim startSlice As Long, endSlice As Long, i As Long, Cols As String, k As Long
 Const shtsNo As Long = 6 'sheets number to split the range
 
 Set wb = ActiveWorkbook 'or Workbooks("My Workbook")
 Set sh = wb.ActiveSheet 'or wb.Sheets("My Sheet")
 lastRow = sh.Range("A" & rows.count).End(xlUp).row 'last row of the sheet to be processed
 lastCol = sh.UsedRange.Columns.count               'last column of the sheet to be processed
 arr = sh.Range(sh.Range("A2"), sh.cells(lastRow, lastCol))      'put the range in an array
 SplCount = WorksheetFunction.Ceiling_Math(UBound(arr) / shtsNo) 'calculate the number of rows for each sheet
 Cols = "A:" & Split(cells(1, lastCol).Address, "$")(1) 'determine the letter of the last column

 clearSheets wb 'delete previous sheets named as "Sheet_" & k
 For i = 1 To UBound(arr) Step SplCount        'iterate through the array elements number
   startSlice = i: endSlice = i + SplCount - 1 'set the rows number to be sliced
   'create the slice aray:
   arrRows = Application.Index(arr, Evaluate("row(" & startSlice & ":" & endSlice & ")"), _
                                                       Evaluate("COLUMN(" & Cols & ")"))
   'insert a new sheet at the end of the workbook:
   Set shNew = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count))
     shNew.Name = "Sheet_" & k: k = k + 1 'name the newly created sheet
   If UBound(arr) - i < SplCount Then SplCount = UBound(arr) - i + 1 'set the number of rows having data
                                                                     'for the last slice
   shNew.Range("A2").Resize(SplCount, lastCol).value = arrRows 'drop the slice array at once
 Next i
End Sub

Sub clearSheets(wb As Workbook)
    Dim ws As Worksheet
    For Each ws In wb.Worksheets
        If left(ws.Name, 7) Like "Sheet_#" Then
            Application.DisplayAlerts = False
             ws.Delete
            Application.DisplayAlerts = True
        End If
    Next
End Sub

Answer 4

试试下面的代码。它通过数据流式传输并动态添加工作表，根据 row# 重命名它们，从第一行复制标题和所需的数据块。

Public Sub DistributeData()
    Const n_sheets As Long = 6
    
    Dim n_rows_all As Long, n_cols As Long, i As Long
    
    Dim r_data As Range, r_src As Range, r_dst As Range
    ' First data cell is on row 2
    Set r_data = Sheet1.Range("A2")
    ' Count rows and columns starting from A2
    n_rows_all = Range(r_data, r_data.End(xlDown)).Rows.Count
    n_cols = Range(r_data, r_data.End(xlToRight)).Columns.Count
    Dim n_rows As Long, ws As Worksheet
    Dim n_data As Long
    n_data = n_rows_all
    ' Get last worksheet
    Set ws = ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets().Count)
    Do While n_data > 0
        ' Figure row count to copy
        n_rows = WorksheetFunction.Min(WorksheetFunction.Ceiling_Math(n_rows_all / n_sheets), n_data)
        ' Add new worksheet after last one
        Set ws = ActiveWorkbook.Worksheets.Add(, ws, , XlSheetType.xlWorksheet)
        ws.Name = CStr(n_rows_all - n_data + 1) & "-" & CStr(n_rows_all - n_data + n_rows)
        ' Copy Headers
        ws.Range("A1").Resize(1, n_cols).Value = _
            Sheet1.Range("A1").Resize(1, n_cols).Value
        ' Skip rows from source sheet
        Set r_src = r_data.Offset(n_rows_all - n_data, 0).Resize(n_rows, n_cols)
        ' Destination starts from row 2
        Set r_dst = ws.Range("A2").Resize(n_rows, n_cols)
        ' This copies the entire block of data
        ' (no need for Copy/Paste which is slow and a memory hog)
        r_dst.Value = r_src.Value
        ' Update remaining row count to be copied
        n_data = n_data - n_rows
        ' Go to next sheet, or wrap around to first new sheet
    Loop
    
    
End Sub

不要使用复制/粘贴，因为它很慢而且有问题。直接从一个单元格写入另一个单元格的值总是一个好主意。您可以使用以下示例中的一条语句对整个单元格表（多行和多列）执行此操作：

ws_dst.Range("A2").Resize(n_rows,n_cols).Value = _
    ws_src.Range("G2").Resize(n_rows,n_cols).Value

Answer 5

Sub split()
On Error Resume Next
Application.DisplayAlerts = False
Dim aws As String
Dim ws As Worksheet
Dim wb As Workbook
Dim sname()
sname = Array("one", "two", "three", "four", "five", "six")
aws = ActiveSheet.Name
For Each ws In Worksheets
If ws.Name = "one" Then ws.Delete
If ws.Name = "two" Then ws.Delete
If ws.Name = "three" Then ws.Delete
If ws.Name = "four" Then ws.Delete
If ws.Name = "five" Then ws.Delete
If ws.Name = "six" Then ws.Delete
Next ws 
lr = (Range("A" & Rows.Count).End(xlUp).Row) - 1
rec = Round((lr / 6), 0)
Set ws = ActiveSheet
f = 1
t = rec + 1
i = 1
While i <= 6
Sheets.Add.Name = sname(i - 1)
Sheets(aws).Select
If i = 6 Then
Range("A" & (f + 1), "A" & (lr + 1)).Select
Else
Range("A" & (f + 1), "A" & t).Select
End If
Selection.Copy
Sheets(sname(i - 1)).Select
Range("A2").Select
ActiveSheet.Paste
Cells(1, 1).Value = ws.Range("A1").Value
f = f + rec
t = t + rec
i = i + 1
Wend
End Sub