Destination copy and paste (values only) for copy loop

**mr_mango81** · 05-01-2013, 08:05 PM

Hi guys I'm trying to copy and paste a title and subtotal from a range of data in columns AD:AF;

Example;
BH113 13/03/2013 72
13/03/2013 106
13/03/2013 67
Total 245

BH114 5/03/2013 92
7/03/2013 77
13/03/2013 90
14/03/2013 59
18/03/2013 52
19/03/2013 44
21/03/2013 88
Total 502

CR102 25/03/2013 107
27/03/2013 117
Total 224

I want to paste the information in columns O:P to look like the following as a summary, so the data needs to be pasted as values only;

BH113 245
BH114 502
CR102 224

Here is the code I have so far,

Sub AAmonth()
Range("AD3").Select 'this is the fisrt cell with data (BH113)
Do Until Selection.Value = ""
    
    Selection.Copy Destination:=Range("O3", Range("O" & Rows.Count).End(xlUp).Offset(1, 0))
Selection.Offset(, 2).End(xlDown).Select

Selection.Copy Destination:=Range("P3", Range("P" & Rows.Count).End(xlUp).Offset(1, 0))
    Selection.Offset(2, -2).Select

Loop
End Sub

This code copies the data into the correct columns, but it doesn't paste values only and the data from clolumn AD all ends up as the last value (CR102)

Help would be greatly appreciated.

**AlvaroSiza** · 05-01-2013, 08:13 PM

Please post a sample workbook. My immediate thought would be to use the pastespecial method against a range object. Something like...

Dim rngTarget As Range
Set rngTarget = Range("O3", Range("0" & Rows.Count).End(xlUp).Offset(1))
Selection.Copy
rngTarget.PasteSpecial xlPasteValues

**mr_mango81** · 05-01-2013, 08:19 PM

Here is an example of my sheet.

**AlvaroSiza** · 05-01-2013, 08:47 PM

An array approach. Please make a copy of your workbook and test on the copy.

Option Explicit

Sub TryThis()

Dim wb          As Workbook
Dim ws          As Worksheet
Dim rngPlant    As Range
Dim rngDest     As Range
Dim pArr()      As Variant
Dim dArr()      As Variant
Dim i           As Integer
Dim j           As Integer
Dim k           As Integer

Set wb = ActiveWorkbook
Set ws = wb.Sheets("Monthly Fuel Summary")

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
        With ws
            Set rngPlant = .Range("AD3", .Range("AF65532").End(xlUp))
            pArr = rngPlant
        End With
        
        ReDim dArr(1 To UBound(pArr), 1 To 2)
        j = 0
        For i = LBound(pArr) To UBound(pArr)
            If pArr(i, 1) <> "" Then
                j = j + 1
                dArr(j, 1) = pArr(i, 1)
            End If
        Next i
        
        j = 0
        For k = LBound(pArr) To UBound(pArr)
            If pArr(k, 2) = "Total" Then
                j = j + 1
                dArr(j, 2) = pArr(k, 3)
            End If
        Next k
        
        Set rngTarget = ws.Range("O3")
        rngTarget.Resize(j, 2) = dArr
        

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub