Advertisement

10.03.2008 at 09:29AM PDT, ID: 23785611 | Points: 500
[x]
Attachment Details

Need to paste copied cell in worksheet

Asked by landman08 in Microsoft Excel Spreadsheet Software, Microsoft Office Suite, Microsoft Applications

Tags: , ,

saurabh726 has been helping with macros in my excel program. The one below copies data and places it on a worksheet specified by the user. I need to add one more thing to the copied data. I need cells A2 and B2 from the copied worksheet to copy over with the other data. It needs to be inserted at the top of the page before the other copied items.  Hope this makes sense! Thanks for your help.Start Free Trial 
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:

'
' ownership Macro
'
' Keyboard Shortcut: Ctrl+u
'
 
Dim ws As Worksheet, ws1 As Worksheet, rng As Range, rng2 As Range
 
Dim H As Range
'On Error Resume Next
Set H = Application.InputBox("Please select sheet from which data need to be moved", Type:=8)
If H Is Nothing Then Exit Sub
ActiveWorkbook.Names.Add Name:="Data", RefersTo:=H
Application.Goto Reference:="Data"
Set ws = ActiveSheet
ActiveWorkbook.Names.Add Name:="Data", RefersTo:=ws.Range("G11:CE11")
ActiveWorkbook.Names.Add Name:="Data1", RefersTo:=ws.Range("G9:CE9")
Set rng = ws.Range("G11:CE11")
Set H = Application.InputBox("Please select the sheet to which data need to be moved", Type:=8)
If H Is Nothing Then Exit Sub
ActiveWorkbook.Names.Add Name:="Data3", RefersTo:=H
Application.Goto Reference:="Data3"
Application.ScreenUpdating = False
Set ws1 = ActiveSheet
 
 
 
ws.Select
Range("G11").Select
stcol = ActiveCell.Column
Do Until Trim(ActiveCell.Value) = ""
ActiveCell.Offset(0, 1).Select
encol = ActiveCell.Column - 1
Loop
Range(Cells(11, stcol).Address & ":" & Cells(11, encol).Address).Copy
ws1.Select
Range("a" & Cells(65536, "a").End(xlUp).Row + 1).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
ws.Select
Range(Cells(3, stcol).Address & ":" & Cells(3, encol).Address).Copy
ws1.Select
Range("b" & Cells(65536, "b").End(xlUp).Row + 1).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
Selection.NumberFormat = "??????/??????"
ws.Select
Range(Cells(9, stcol).Address & ":" & Cells(9, encol).Address).Copy
ws1.Select
Range("c" & Cells(65536, "c").End(xlUp).Row + 1).Select
Selection.PasteSpecial Paste:=xlValues, Transpose:=True
Cells.Select
Selection.EntireColumn.AutoFit
Range("a2").Select
a = 2
Dim rng1 As Range
Set rng1 = Range("A2:A" & Cells(65536, "A").End(xlUp).Row)
Do Until a > Cells(65536, "a").End(xlUp).Row
 
x = Application.WorksheetFunction.CountIf(rng, ActiveCell.Value)
 
 
y = Application.Evaluate("Sumproduct((Data=""" & ActiveCell.Value & """)*(Data1=" & ActiveCell.Offset(0, 2).Value & "))")
 
If (ActiveCell.Offset(0, 2).Value = 0 Or ActiveCell.Value = "" Or x = 0 Or Application.WorksheetFunction.CountIf(rng1, ActiveCell.Value) > x Or y = 0) Then
Rows(a).Delete
Range("a" & a).Select
Else
ActiveCell.Offset(1, 0).Select
a = a + 1
End If
Loop
 
 
Range("a1").Select
 
Application.CutCopyMode = False
 
ws.Select
Dim Nme As Name
For Each Nme In Names
            Nme.Delete
Next Nme
Range("a1").Select
Application.ScreenUpdating = True
 
 
End Sub
[+][-]10.03.2008 at 12:07PM PDT, ID: 22637003

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]10.03.2008 at 12:38PM PDT, ID: 22637285

Often, when Experts are collaborating with members who have asked questions, they will request additional information about the problem. Askers respond with an author comment like this one.

Start your 7-day free trial to view this Author Comment or ask the Experts your question.

 
[+][-]10.03.2008 at 02:25PM PDT, ID: 22638217

At Experts Exchange, members can ask their questions to thousands of technology professionals, also known as Experts. Experts compete and collaborate to answer those questions by leaving comments like this one.

Start your 7-day free trial to view this Expert Comment or ask the Experts your question.

 
[+][-]11.29.2008 at 11:23PM PST, ID: 23062255

Experts Exchange has a courteous staff of administrators who help members get the most out of the website by means of administrative comments like this one.

Start your 7-day free trial to view this Administrative Comment or ask the Experts your question.

 
 
Loading Advertisement...
20080716-EE-VQP-32 - Hierarchy / EE_QW_2_20070628