VBA - Transferring select Data to new sheet [Solved/Closed]

VirtualInsanity - May 17, 2012 at 03:42 PM - Latest reply:  VirtualInsanity
- Jun 19, 2012 at 06:23 PM
Hey there, I'm trying to create a macro for an Excel 2003 spreadsheet that will take a record (a row (or rows)) that I've already selected into a new sheet (I'll call this spreadsheet Archive) . The only catch is the Archive sheet will only have some of the headers that the original sheet has i.e. I only want to copy certain details not the whole row, so I'm wondering how to get it to look at the headings and only copy the data across that matches the headings on the Archive spreadsheet. Removing the records from the original spreadsheet in the process.

Any help you can offer is much appreciated!
See more 

10 replies

Best answer
TrowaD 2395 Posts Sunday September 12, 2010Registration date July 17, 2018 Last seen - May 29, 2012 at 10:04 AM
1
Thank you
Hi VirtualInsanity,

Your last post definitely made things a lot easier.
Unfortunately I couldn't get it to work for multiple rows.

So select a row or a cell from that row and run the code:

Sub MoveData()
Dim lRow, x As Integer
Dim ws1, ws2, ws3 As String

'Make sure the following sheet names are correct.
ws1 = "Original1"
ws2 = "Original2"
ws3 = "Archive"

x = ActiveCell.Row
lRow = Sheets(ws3).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row

'When neither original sheets are selected, a messagebox will let you know.
If ActiveSheet.Name <> ws1 And ActiveSheet.Name <> ws2 Then _
MsgBox "Please select either sheet " & ws1 & " or " & ws2 & " before running this macro."

If ActiveSheet.Name = ws1 Then
Union(Cells(x, "A"), Cells(x, "B"), Cells(x, "C"), Cells(x, "D"), Cells(x, "E"), Cells(x, "H"), Cells(x, "J")).Copy _
Destination:=Sheets(ws3).Range("A" & lRow)
Union(Cells(x, "A"), Cells(x, "B"), Cells(x, "C"), Cells(x, "D"), Cells(x, "E"), Cells(x, "H"), Cells(x, "J")).ClearContents
End If

If ActiveSheet.Name = ws2 Then
Union(Cells(x, "A"), Cells(x, "B"), Cells(x, "C"), Cells(x, "D"), Cells(x, "E"), Cells(x, "G"), Cells(x, "L"), Cells(x, "S")).Copy _
Destination:=Sheets(ws3).Range("A" & lRow)
Union(Cells(x, "A"), Cells(x, "B"), Cells(x, "C"), Cells(x, "D"), Cells(x, "E"), Cells(x, "G"), Cells(x, "L"), Cells(x, "S")).ClearContents
End If

End Sub

Best regards,
Trowa

Thank you, TrowaD 1

Something to say? Add comment

CCM has helped 1705 users this month

VirtualInsanity - Jun 13, 2012 at 07:15 PM
Thanks Trowa - this was good but it was a bit clunky as it was referencing actual cells instead of the headings, so it didn't allow for easy changes to be made to the document.

I was desperate for an answer and asked on another forum as well and got this code in answer:

'takes selected rows of data and transfers to the Archive spreadsheet
Sub ArchiveToCurrent()

Dim fnd As Range, rngSel As Range
Dim shCurrent As Worksheet, shDestin As Worksheet
Dim shSource As Variant, arrSource As Variant
Dim nxRow As Long, r1 As Long, r2 As Long
Dim stCol As Long, enCol As Long, c As Long

Application.ScreenUpdating = False

Set shCurrent = ActiveSheet
Set shDestin = Sheets("Archive")

arrSource = Array("Current") 'change as needed
For Each shSource In arrSource
Sheets(shSource).Activate
For Each rngSel In Selection.Areas
stCol = rngSel.Cells(1, 1).Column
enCol = stCol + rngSel.Columns.Count - 1
nxRow = shDestin.Cells(1, 1).CurrentRegion.Rows.Count + 1
For c = stCol To enCol
If Cells(1, c) = "" Then Exit For
Set fnd = shDestin.Rows(1).Find(Cells(1, c), , , xlWhole)
If Not fnd Is Nothing Then
r2 = nxRow
For r1 = 1 To rngSel.Rows.Count
shDestin.Cells(r2, fnd.Column) = rngSel.Cells(r1, c - stCol + 1).Value
r2 = r2 + 1
Next r1
End If
Set fnd = Nothing
Next c
Next rngSel
For Each rngSel In Selection.Areas
rngSel.ClearContents
Next rngSel
Next shSource
shCurrent.Activate

ActiveSheet.Select
Selection.EntireRow.Delete
End Sub

Which works beautifully - I hope you find it helpful too :)

I've got one other question though and the other forum is down at the moment so I couldn't go back to the original person who wrote this - so wondered if you might know the answer?

I want to use this code to copy the selected rows to another spreadsheet (which it does already) but this time I want it to include on the destination worksheet the name of the worksheet the information was taken from - in a column which is headed 'Sheet Name'.

Do you have any suggestions?
VirtualInsanity - Jun 14, 2012 at 10:04 PM
Actually ignore my above question. I found a work around. I would however like to use the code you gave me to do something slightly different...

I tried adapting it but couldn't quite work out the right way to do it.

I'd like to use your code to shift a selected row to another spreadsheet taking specific cells from the selection and placing them in very specific locations e.g. copy the cell located in column A of the selected range and paste to C4 on the new sheet, copy the cell located in column Bof the selected range and paste to D4 on the new sheet, copy the cell located in column E of the selected range and paste to C13 on the new sheet etc.

Are you able to suggest some tweaks to your code for doing this?

Your help is sincerely appreciated :)
TrowaD 2395 Posts Sunday September 12, 2010Registration date July 17, 2018 Last seen - Jun 18, 2012 at 10:17 AM
Hi VirtualInsanity,

Thanks for sharing the code and good to see you are getting closer to getting the desired result.

Now for your recent question let's look at a part of my posted code:
If ActiveSheet.Name = ws1 Then
Union(Cells(x, "A"), Cells(x, "B"), Cells(x, "C"), Cells(x, "D"), Cells(x, "E"), Cells(x, "H"), Cells(x, "J")).Copy _
Destination:=Sheets(ws3).Range("A" & lRow)
Union(Cells(x, "A"), Cells(x, "B"), Cells(x, "C"), Cells(x, "D"), Cells(x, "E"), Cells(x, "H"), Cells(x, "J")).ClearContents
End If

Change this into:
If ActiveSheet.Name = ws1 Then
Cells(x,"A").cut Destination:=Sheets(ws3).Range("C4")
Cells(x,"B").cut Destination:=Sheets(ws3).Range("D4")
Cells(x,"E").cut Destination:=Sheets(ws3).Range("C13")
End if

This way you can simply add additional cut/paste actions.
Do NOTE that the destination cells will be overwritten when running the code subsequent times.

Best regards,
Trowa
VirtualInsanity - Jun 18, 2012 at 10:26 PM
Brilliant - thanks so much :)

One last quick question. Is there a way to get it to presevere the formatting of the destination cell. So only copying across the text - not the formats?
TrowaD 2395 Posts Sunday September 12, 2010Registration date July 17, 2018 Last seen - May 22, 2012 at 09:11 AM
0
Thank you
Hi VirtualInsanity,

Let's see if I understand your query.

When you select a row from the original sheet and run the macro, you wish to cut/paste certain columns of that row to the Archive sheet.

Since I assume the headers won't change, you can already tell me which columns you would like to cut/paste.

Do let me know if this is correct and if you might have other preferences.

Best regards,
Trowa
VirtualInsanity - May 22, 2012 at 03:52 PM
Hi TrowaD,

Yes that's essentially it. We actually have 2 original spreadsheets that hold data - some of the headers are the same , some different. The idea is we want to create a button that runs a macro and takes the highlighted row (or rows) of data from whatever original spreadsheet we're on and copies it to an archive sheet. The archive sheet will only have the headings of the data that we want to keep (matching some the headings on the 2 original spreadsheets) but there would be some headings on the Archive Sheet that are specific to original spreadsheet 1 but not original spreadsheet 2 and vice versa. Hope that makes sense?
VirtualInsanity - May 24, 2012 at 05:24 PM
Just some additional info that might help.

On original spreadsheet 1 the columns with the data we want to keep are A,B,C,D,E, H, J.
On original Spread Sheet 2 the columns with the data we want to keep are A,B,C,D,E, G, L and S.

When we select a row from which ever of the original sheets we're on and run the macro, we wish to cut/paste the data from those columns of that row to the Archive sheet.

Hope that's helpful. Looking forward to hearing your thoughts on this...
TrowaD 2395 Posts Sunday September 12, 2010Registration date July 17, 2018 Last seen - Jun 19, 2012 at 09:25 AM
0
Thank you
For that we need a different structure:

If ActiveSheet.Name = ws1 Then
Cells(x, "A").Copy
Sheets(ws3).Range("C4").PasteSpecial Paste:=xlPasteValues
Cells(x, "A").ClearContents
Cells(x, "B").Copy
Sheets(ws3).Range("D4").PasteSpecial Paste:=xlPasteValues
Cells(x, "B").ClearContents
Cells(x, "E").Copy
Sheets(ws3).Range("C13").PasteSpecial Paste:=xlPasteValues
Cells(x, "E").ClearContents
End If

Since we are not using "Destination:=" anymore, you need to put "Application.CutCopyMode = False" just above the "End Sub" line to clear Excel's memory.

Best regards,
Trowa
VirtualInsanity - Jun 19, 2012 at 06:23 PM
0
Thank you
Brilliant - thank you so much for all your help! :)