Snasui Excel Forum

Code: Select all

Sub PasteData()
Dim rs1 As Range, rs2 As Range
Dim rt1 As Range, rt2 As Range
Application.ScreenUpdating = False
With Worksheets("Multi App")
    Set rs1 = .Range("F12:F21,F23,F25:F26,F28,F30,F36:F37,F40:F44,F48")
    Set rs2 = .Range("E54:E55,E57,E59:E60")
End With
With Worksheets("Database")
    Set rt1 = .Range("D" & Rows.Count).End(xlUp).Offset(1, 0)
    Set rt2 = rt1.Offset(0, 23)
End With
rs1.Copy: rt1.PasteSpecial Paste:=xlPasteValues, Transpose:=True
rs2.Copy: rt2.PasteSpecial Paste:=xlPasteValues, Transpose:=True
rs1.ClearContents
rs2.ClearContents
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Finish"
End Sub