VBA: Kopieren von Segmenten von Daten auf ein anderes Blatt

Question

Das erste, was ich bin ein Neuling mit VBA bitte sei sanft. Mein Code ist unter dem Bild und dieser Code muss Department # lesen und kopieren Sie alles, was unter der Department # kommt, bis die nächste Department # Ansätze und fügen Sie die kopierten Daten in ein zugeordnetes Blatt für diese Abteilungen.

In diesem Bild Department 73 beginnt in (A1: H1) endet an (A30: H30). Die nächste Abteilung beginnt in der Linie 31 und endet in der Linie 37. Die Sache ist, dass es 80 Abteilungen gibt und jede von ihnen ihr eigenes Blatt hat. Diese Excel-Dateien werden auf diese Weise formatiert. Ist es möglich, ein Makro zu schreiben, das Abteilungen finden kann, indem man Konten liest und drei Zeilen darüber kopiert und NUR seine eigenen Werte, die darunter liegen, bis es die nächsten Abteilungsmitglieder erreicht und diese Werte in ein zugewiesenes Blatt einfügt. Wie Abteilung 3, Abteilung 5.

Dieser Code ist nur Brainstorming, ich weiß nicht genau, wie Sie das programmieren ... Bitte helfen, wenn Sie Erfahrung haben.

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

Basierend auf unseren Chat, glaube ich, die folgenden Code Ihre Daten in die Blätter verteilt werden Sie bereits eingerichtet haben:

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