Copy/Paste?

[Mike G - DC]

Folks - I'm looking for some code to copy data from worksheet A into
Worksheet B like the following example. This code will fire as part of
another macro. Any help is much appreciated.
Thanks, Mike


Worksheet A
A B C
1 item1 10 20
2 item2 12 19
3 item3 13 89


Worksheet B
A B
1 item1 10
2 item1 20
3 item2 12
4 item2 19
5 item3 13
6 item3 89

 

[Don Guillett]

Is there ever more than one item1 in col A and are there ever more than 2
other columns? Easier if yes.

 

[Per Jessen]

Hi
Try this.

Sub CopyPaste()
Dim shA As Worksheet
Dim shB As Worksheet
Dim LastRow As Long
Dim r As Long
Dim Item As String

Set shA = Worksheets("Sheet1") 'Change to suit
Set shB = Worksheets("Sheet2") 'Change to suit

LastRow = shA.Range("A1").End(xlDown).Row

For rw = 1 To LastRow
Item = shA.Cells(rw, 1)
r = r + 1
shB.Range("A" & r & ":A" & r + 1) = Item
shB.Cells(r, 2) = shA.Cells(rw, 2)
r = r + 1
shB.Cells(r, 2) = shA.Cells(rw, 3)
Next
End Sub

Regards,
Per

 

[ryguy7272]

Hi, just thought the poster may want to see a small modification required to
Per's code:

Sub CopyPaste()
Dim shA As Worksheet
Dim shB As Worksheet
Dim LastRow As Long
Dim r As Long
Dim Item As String

Set shA = Worksheets("Sheet1") 'Change to suit
Set shB = Worksheets("Sheet2") 'Change to suit

LastRow = shA.Range("A1").End(xlDown).Row

For rw = 1 To LastRow
Item = shA.Cells(rw, 1)
r = r + 1
shB.Cells(r, 2) = shA.Cells(rw, 2)
r = r + 1
shB.Cells(r, 2) = shA.Cells(rw, 2) & " " & shA.Cells(rw, 3)
r = r + 1
shB.Cells(r, 2) = shA.Cells(rw, 2) & " " & shA.Cells(rw, 4)
Next

End Sub

HTH,
Ryan---

 

[Mike G - DC]

Looks like my example may have adjusted a bit after the fact. Column A will
include an indefinite list of items. Although most will be unique there is a
chance that there may be duplicate item names. My data set actually includes
Data in columns A through O. Column A captures the item and column B through
O capture a numeric count of the item each month. I limited my example
thinking that I could modify the code. Any help is much appreciated.
Thanks, Mike

 

[Don Guillett]

This should work. Fire from the DESTINATION sheet
Sub remakelist()
Application.ScreenUpdating = False
Sheets("sheet1").Columns("a").Copy Range("a1")
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
Rows(i - 1).Insert
For j = 2 To Cells(i, Columns.Count).End(xlToLeft).Column
Cells(i, 1).Copy Cells(i - 1, 1)
Cells(i, j).Copy Cells(i - 1, 2)
Next j
Next i
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns("c").Delete
Application.ScreenUpdating = True
End Sub

 

[Mike G - DC]

Excellent! Thanks for the help.

This should work. Fire from the DESTINATION sheet
Sub remakelist()
Application.ScreenUpdating = False
Sheets("sheet1").Columns("a").Copy Range("a1")
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
Rows(i - 1).Insert
For j = 2 To Cells(i, Columns.Count).End(xlToLeft).Column
Cells(i, 1).Copy Cells(i - 1, 1)
Cells(i, j).Copy Cells(i - 1, 2)
Next j
Next i
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns("c").Delete
Application.ScreenUpdating = True
End Sub

--
Don Guillett
Microsoft MVP Excel
SalesAid Software
(e-mail address removed)

 

[Mike G - DC]

This is method works as well. Thanks for the help.

 

[Don Guillett]

If using this you may desire to add the sort to the end of the macro.
'======
..Columns("A:B").Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Key2:=.Range("B1"), Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

--
Don Guillett
Microsoft MVP Excel
SalesAid Software
(e-mail address removed)
Hi
Try this.

Sub CopyPaste()
Dim shA As Worksheet
Dim shB As Worksheet
Dim LastRow As Long
Dim r As Long
Dim Item As String

Set shA = Worksheets("Sheet1") 'Change to suit
Set shB = Worksheets("Sheet2") 'Change to suit

LastRow = shA.Range("A1").End(xlDown).Row

For rw = 1 To LastRow
Item = shA.Cells(rw, 1)
r = r + 1
shB.Range("A" & r & ":A" & r + 1) = Item
shB.Cells(r, 2) = shA.Cells(rw, 2)
r = r + 1
shB.Cells(r, 2) = shA.Cells(rw, 3)
Next
End Sub

Regards,
Per