VBA：将数据段复制到另一个工作表上

首先，我是VBA的新手请温和。 我的代码位于图片下方，此代码必须读取Department #并复制Department #下的所有内容，直到下一个Department #接近并将复制的数据粘贴到该部门的指定表单中。

在这张照片中，在（A1：H1）开始的Department 73在（A30：H30）结束 。 下一个部门从第31行开始，到第37行结束。事情是有80个部门，每个部门都有自己的工作表。 这个excel文件是这样格式化的。 是否可以编写一个macros，通过读取帐户来定位Departments＃并复制它上面的三行，并将它自己的值直接到达下一个部门成员，并将这些值粘贴到指定的工作表中。 像部门3，部门5一样。

这个代码只是头脑风暴，我不完全知道如何编码…请帮助，如果你有经验。

  Sub copyingdata() Dim sec1 As Long Dim Counter As Integer Dim MyString As String MyString = "Department 63" For i = 1 To Len(MyString) sec1 = WorksheetFunction.Match("Department 60", .Columns("A"), 0) sec1.Resize(i).Select Selection Sheets("Sheet1").Selection.Copy Destination:=Sheets("Amanda").Range("A1") Sheets("Sheet1").Selection.Copy Sheets("Amanda").Activate Range("A1").Select ActiveSheet.Paste Application.CutCopyMode = False End Sub 

Answer 1

基于我们的聊天，我相信下面的代码将您的数据拆分成您已经设置的工作表：

 Sub AllocateDepartmentData() Dim prevRow As Long Dim deptRow As Long Dim deptNum As Variant Dim destSheet As String Dim destRow As Long prevRow = 0 'Find the end of the first section deptRow = Range("A:A").Find(What:="Department", LookIn:=xlValues, LookAt:=xlPart).Row Do While deptRow > prevRow 'Parse the cell containing the department number/name to get just the number deptNum = Cells(deptRow, 1).Value deptNum = Mid(deptNum, InStr(deptNum, " ") + 1) deptNum = CInt(Left(deptNum, InStr(deptNum & " ", " ") - 1)) 'Based on the department number, determine the destination sheet Select Case deptNum 'One "Case" statement should be set for each destination sheet name Case 1, 2, 60, 61, 63 destSheet = "Amanda" 'Add more "Case" statements for each sheet Case 73, 74 destSheet = "Shannon" 'And finally catch any departments that haven't been allocated to a sheet Case Else MsgBox "Department " & deptNum & " has not been allocated to anyone!" End End Select With Worksheets(destSheet) 'Work out which row to copy to destRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 'destRow will be 2 if the sheet was currently empty, so adjust to be 1 instead If destRow = 2 Then destRow = 1 'Copy everything from the end of the previous section to the end of this section Rows((prevRow + 1) & ":" & deptRow).Copy Destination:=.Range("A" & destRow) End With 'Set up for next section prevRow = deptRow deptRow = Range("A:A").FindNext(Cells(deptRow, "A")).Row 'The loop will stop once the newly found "Department" is on a row before the last processed section Loop End Sub