问将特定范围从一个工作表复制到另一个操作目标地址

EN

Sub PopulateCells()
    Dim rng As Range
    Dim rng2 As Range
    Dim LastCell As String
    Dim Dest As String

    Application.ScreenUpdating = False
    
    'Cleans BI worksheet
    Ark4.Cells.Delete
    
    'Initialize Row- and Column numbers
    Startrow = 4
    StartColumn = 7
    EndColumn = 18
    
    Ark3.Activate
    
    'Finds adresses and ranges to be used in macro
    Set rng = Sheets(Sheets.Count).Cells
    lastrow = Last(1, rng)
    dColumns = Last(2, rng)
    aKol = dColumns
    LastCell = Last(3, rng)
    Set rng = Parent.Range("G4", LastCell)
    Set rng2 = Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn))
    cColumn = Round(dColumns / 12, 0) 'Total number of columns divided by 12, which equals 1 year
    
    'Finds address on last column with data
    sKol = Ark3.Cells(3, Columns.Count).End(xlToLeft).Address
        
    'Initialize a row indicatorvariable + fills out dummy data in the BI worksheet to match the code
    Ark4R = 3
    Ark4.Range("A1:" & sKol).Value = "x"
        
    ' Loop all rows in the datasheet
    For I = 4 To lastrow
        
        'Loop all columns in datasheet (in group of 12)
        For ii = 1 To cColumn
            
            'Initialize a range (rng2) to see if there is data in the range
            Set rng2 = Ark3.Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn))
            
                'fills relevant data in the data source sheet
                If WorksheetFunction.countA(rng2) <> 0 Then
                    Ark3.Range("E" & I).Value = rng2.EntireColumn.Cells(1).Value
                    Ark3.Range("F" & I).Value = rng2.EntireColumn.Cells(1).Offset(1).Value
                    aRowSource = Ark3.Range(Cells(Startrow, StartColumn), Cells(Startrow, EndColumn)).Row
                
                'Copy to data destination sheet
                    rng2.EntireRow.Copy 'Copy the entire row
                    Ark4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll    'Paste entire row to the next empty row in destination sheet
                    Application.CutCopyMode = False
                    Ark4.Range(Ark4.Cells(ActiveCell.Row, 7), Ark4.Cells(ActiveCell.Row, aKol)).ClearContents   'Clear hour-registration data in destination sheet
                    aRowDest = Range(Ark4.Cells(ActiveCell.Row, 7), Ark4.Cells(ActiveCell.Row, aKol)).Row   'Get row number in destionation sheet
                    Dest = rng2.Address(RowAbsolute:=False, ColumnAbsolute:=False)  'Get the address range of the hour-registration in the source sheet
                    Dest = Replace(Dest, aRowSource, aRowDest)  'Manipulate the address to match the location in the destination sheet
                    rng2.Copy Ark4.Range(Dest)  'Copy the range to the destination sheet
                    Application.CutCopyMode = False

                End If

                'Counter - takes the next 12 cells = 1 year
                StartColumn = StartColumn + 12
                EndColumn = EndColumn + 12
        
        Next ii 'Next cColumn
        
        'Make a new row to cater for operation hours (inserted by another procedure)
        Ark3.Range(Cells(Startrow, 1), Cells(Startrow, 4)).Copy
        Ark4.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
        Application.CutCopyMode = False
        
        'Counters
        Startrow = Startrow + 1
        StartColumn = 7
        EndColumn = 18
    Next I

End Sub