• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to automate copy/paste from one sheet to another

Manny Singh

Member
Hi All,

This is my first post on this forum so please excuse if I haven't explained well.

I have explained the query on attached file, I would appreciate if someone can help.


Thanks,
Manny
 

Attachments

  • Book1.xlsx
    70.9 KB · Views: 5
Code:
Option Explicit

Sub Manny()
    Dim i As Long, lr As Long
    Dim s1 As Worksheet, s2 As Worksheet
    Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range
    Set s1 = Sheets("Sheet 1")
    Set s2 = Sheets("Sheet 2")
    Set r1 = s2.Range("A19")
    Set r2 = s2.Range("C44")
    Set r3 = s2.Range("C48")
    Set r4 = s2.Range("C60")
    lr = s1.Range("R" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    With s1
        For i = 2 To lr
            .Range("R" & i).Copy r2
            .Range("S" & i).Copy r1
            .Range("S" & i).Copy r3
            r4.Copy
            s1.Range("W" & i).PasteSpecial xlPasteValues
        Next i
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub


Note: This code will work only if you unmerge A19, C44, and C48 on Sheet 2. VBA does not like to work on merged cells. I tested and it works for all inputs except where you have an underscore and no value. You may wish to adjust that as well.
 
Code:
Option Explicit

Sub Manny()
    Dim i As Long, lr As Long
    Dim s1 As Worksheet, s2 As Worksheet
    Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range
    Set s1 = Sheets("Sheet 1")
    Set s2 = Sheets("Sheet 2")
    Set r1 = s2.Range("A19")
    Set r2 = s2.Range("C44")
    Set r3 = s2.Range("C48")
    Set r4 = s2.Range("C60")
    lr = s1.Range("R" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    With s1
        For i = 2 To lr
            .Range("R" & i).Copy r2
            .Range("S" & i).Copy r1
            .Range("S" & i).Copy r3
            r4.Copy
            s1.Range("W" & i).PasteSpecial xlPasteValues
        Next i
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub


Note: This code will work only if you unmerge A19, C44, and C48 on Sheet 2. VBA does not like to work on merged cells. I tested and it works for all inputs except where you have an underscore and no value. You may wish to adjust that as well.
Thanks Alan, much appreciated.
 
Back
Top