Taking certain values from a repeated range and pasting them as a row

Question

UPDATE The solution from VBasic2008 works great but I forgot to mention that "all employees" in the names column has a different size array. Adding in another if loop can hopefully correct this? See the screenshot.

The first name is "grouped" as A2:C7. From that range am looking to copy paste the name, job and 2nd and 5th number in column B. This would then loop for the next people and job functions. Attached are some screenshots for context:

Data Dumps

Desired Output

Sub ArrangeDailyCumulations()

' Source
Const sName As String = "Data Dump"
Const sfCol As String = "A"
Const sfRow As Long = 1
Const sTextColOffset As Long = 1
Const sNumbersCount As Long = 5
Dim sRowOffsets As Variant: sRowOffsets = VBA.Array(0, 0, 2, 5)
Dim sColOffsets As Variant: sColOffsets = VBA.Array(0, 1, 1, 1)
' Destination
Const dName As String = "Daily Cumulations"
Const dfCol As String = "A"
Const dfRow As Long = 2
Dim dColOffsets As Variant: dColOffsets = VBA.Array(1, 0, 3, 2)
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

' Reference the source worksheet and calculate the last row.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.count, sfCol).End(xlUp).row

' Reference the destination worksheet, the destination first cell
' and calculate the number of rows from the first cell to the bottom.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Cells(dfRow, dfCol)
Dim dwsrCount As Long: dwsrCount = dws.Rows.count - dfCell.row + 1

' Clear the destination column data.

Dim oUpper As Long: oUpper = UBound(dColOffsets)

Dim o As Long
    
For o = 0 To oUpper
    dfCell.Offset(, dColOffsets(o)).Resize(dwsrCount).Clear
Next o

' Write the values from the source to the destination worksheet.

Dim sCell As Range
Dim sr As Long
Dim dCell As Range
Dim ddrCount As Long

For sr = sfRow To slRow
    Set sCell = sws.Cells(sr, sfCol)
    If Not IsNumeric(sCell.Offset(, sTextColOffset)) Then ' not numeric
        ddrCount = ddrCount + 1
        For o = 0 To oUpper
            dfCell.Offset(, dColOffsets(o)).Value _
                = sCell.Offset(sRowOffsets(o), sColOffsets(o)).Value
        Next o
        Set dfCell = dfCell.Offset(1)
        sr = sr + sNumbersCount
    'Else ' the cell value is a number or is empty (also numeric in vBA)
    End If
Next sr

' Inform.
MsgBox "Number of cumulations copied: " & ddrCount, vbInformation

End Sub

Answer 1

Besides all the answers above, another way :

The code assumed that there is a consistency of the data in sheet "Bulk Dump", which is something like this :

1. The cell to the left of each name (A, B, C, etc) is the Job Function value
2. the cell to the right of each name is always blank and the rest is always with value (column C)
3. the second row after the row of each name in column B is the Time Stamp value
4. the fifth row after the row with each name in column B is the Time Allocated value

Sub test()
Dim rg As Range: Dim cell As Range
Dim ws1 As Worksheet, ws2 As Worksheet
    
Set ws1 = Worksheets("Data Dump")
Set ws2 = Worksheets("Daily Cumulations")
    
    With ws1
        Set rg = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Offset(0, 1)
    End With
    
    With ws2
        Set oFill = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        .Range("A1").Value = "Name": .Range("B1").Value = "Job Function"
        .Range("C1").Value = "Time Stamp": .Range("D1").Value = "Time Allocated"
    End With
    
    For Each cell In rg.SpecialCells(xlCellTypeBlanks)
        oFill.Value = cell.Offset(0, -1)
        oFill.Offset(0, 1).Value = cell.Offset(0, -2)
        oFill.Offset(0, 2).Value = cell.Offset(2, -1)
        oFill.Offset(0, 3).Value = cell.Offset(5, -1)
        Set oFill = oFill.Offset(1, 0)
    Next
    
End Sub

Result in ws2:

The sub set the range of the data in column B then offset the range (0,1) into variable rg.

Then it loops to each cell in rg which is blank and used this blank cell as the indicator that the cell to the left of this blank cell is the name. And so on.

Answer 2

Copy From Groups of Data

• The second screenshot of the source data is showing that the data is not consistent row-wise hence some of the complications.
• Most of the remaining complications are due to making the code dynamic.
• Adjust (play with) the values in the constants section.

Option Explicit

Sub CopyDailyCumulations()
    
    ' Source
    Const sName As String = "Data Dump"
    Const sfCol As String = "A"
    Const sfRow As Long = 1
    Const sTextColOffset As Long = 1
    Const sNumbersCount As Long = 5
    Dim sRowOffsets As Variant: sRowOffsets = VBA.Array(0, 0, 2, 5)
    Dim sColOffsets As Variant: sColOffsets = VBA.Array(0, 1, 1, 1)
    ' Destination
    Const dName As String = "Daily Cumulations"
    Const dfCol As String = "A"
    Const dfRow As Long = 2
    Dim dColOffsets As Variant: dColOffsets = VBA.Array(1, 0, 3, 2)
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source worksheet and calculate the last row.
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, sfCol).End(xlUp).Row
    
    ' Reference the destination worksheet, the destination first cell
    ' and calculate the number of rows from the first cell to the bottom.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Cells(dfRow, dfCol)
    Dim dwsrCount As Long: dwsrCount = dws.Rows.Count - dfCell.Row + 1
    
    ' Clear the destination column data.
    
    Dim oUpper As Long: oUpper = UBound(dColOffsets)
    
    Dim o As Long
        
    For o = 0 To oUpper
        dfCell.Offset(, dColOffsets(o)).Resize(dwsrCount).Clear
    Next o
    
    ' Write the values from the source to the destination worksheet.
    
    Dim sCell As Range
    Dim sr As Long
    Dim dCell As Range
    Dim ddrCount As Long
    
    For sr = sfRow To slRow
        Set sCell = sws.Cells(sr, sfCol)
        If Not IsNumeric(sCell.Offset(, sTextColOffset)) Then ' not numeric
            ddrCount = ddrCount + 1
            For o = 0 To oUpper
                dfCell.Offset(, dColOffsets(o)).Value _
                    = sCell.Offset(sRowOffsets(o), sColOffsets(o)).Value
            Next o
            Set dfCell = dfCell.Offset(1)
            sr = sr + sNumbersCount
        'Else ' the cell value is a number or is empty (also numeric in vBA)
        End If
    Next sr

    ' Inform.
    MsgBox "Number of cumulations copied: " & ddrCount, vbInformation

End Sub

Answer 3

Something like this might work (assuming your blocks are all the same size and start in the same place)

Sub DailyCumulations2()
    
    Dim rng As Range
    Dim ws1 As Worksheet, ws2 As Worksheet
    
    Set ws1 = Worksheets("Data Dump")
    Set ws2 = Worksheets("Daily Cumulations")
    
    Set rng = ws1.Range("A2:B7")
    Do While Len(rng.Cells(1).Value) > 0 'while there's content...
        'next empty row on ws2
        With ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1).EntireRow
            'populate data for this row
            .Cells(1).Resize(1, 4).Value = Array(rng.Cells(1, 1).Value, _
                                                 rng.Cells(1, 2).Value, _
                                                 rng.Cells(3, 2).Value, _
                                                 rng.Cells(6, 2).Value)
        
        End With
        Set rng = rng.Offset(rng.Rows.Count, 0) 'next block down
    Loop 
End Sub