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

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 DailyCumulations2()
    Dim row As Long
    Dim lastrow1 As Long, lastrow2 As Long
    
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Data Dump")
    Set ws2 = Worksheets("Daily Cumulations")
        
    lastrow1 = ws1.Range("B" & Cells.Rows.count).End(xlUp).row
   
    For row = 1 To lastrow1
        If Excel.WorksheetFunction.IsText(ws1.Range("B" & row).Value) 
    Then
            ws2.Range("A" & row).Value = ws1.Range("B" & row).Value
            ws2.Range("B" & row).Value = ws1.Range("A" & row).Value
            ws2.Cells(row   1, 3).Value = ws1.Cells(row   5, 2).Value
            ws2.Cells(row   1, 4).Value = ws1.Cells(row   2, 2).Value           
        End If
    Next
   
    ws2.Range("A" & row).SpecialCells(xlCellTypeBlanks).DeleteShift:=xlUp
End Sub

CodePudding user response：

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

CodePudding user response：

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