Autocopy selected content from 1 sheet to another sheetClosed

Question

Hello, 

I am creating a little database and I have several sheets called "Main", "study1", "study 2" and "study 3'

I am only entering data into my Main sheet which include things like name, sex etc

What I want to do is that, for example, Person A is in Study A. Person B is in Study B and C

Is it possible that Excel can automatically put all Person A info into Sheet "Study A" and put all Person B info into Sheet "Study B" and Sheet "Study C"?

Many thanks!!!

vcoolio · Answer

Hello Maxi,

Your explanation conflicts a little in that you first mention the sheet names as Study1, Study2 and Study3 but then you refer to them as Study A, Study B and Study C later in your post.

However, I'll assume the latter and think that the following code may help you:-


Option Explicit

Sub TransferData()

Dim ar As Variant, i As Integer

ar = [{"Study A","Study B","Study C";"Person A","Person B", "Person C"}]

Application.ScreenUpdating = False

For i = 1 To UBound(ar, 2)
      Sheets(ar(1, i)).UsedRange.Offset(1).ClearContents
        With Sheet1
            .AutoFilterMode = False
                With Range("A1", Range("A" & Rows.Count).End(xlUp))
                    .AutoFilter 1, ar(2, i)
                    .EntireRow.Copy
                    Sheets(ar(1, i)).Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteValues
                    ActiveSheet.AutoFilterMode = False
                    Sheets(ar(1, i)).Columns.AutoFit
             End With
     End With
Next i
    
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Data transfer completed!", vbExclamation, "STATUS"

End Sub

The code filters/searches Column A for the persons' name and then transfers the relevant row of data to the relevant sheet.

Following is the link to my test work book based on what you have explained. Click on the "RUN" button to see it work:-

https://www.dropbox.com/s/s81mmqu5dnuvwg7/Maxi%28Master%20sht%20to%20multi%2C%20autofilter%2C%20array%29.xlsm?dl=0

I hope that this helps.

Cheerio,
vcoolio.

Maxi · Answer

Hello vcoolio

Many thanks for your quick reply. Sorry I am not very good at Excel, is it Macro? I think I will need some time to understand your coding. I will certainly give it a try tomorrow.

However, looking at your coding, does it only do Study A to C and Person A to C only? what happen if I have more people, say up to Person Z?

Thanks and have a good day
Maxi

vcoolio · Answer

Hello Maxi,

Yes, the code above is a macro with a macro being any VBA code written for Excel purposes such as yours.

The code above does only deal with the three sheets as per your opening post. However, if you expect that your data and number of sheets will grow, we can go down a different road. We can allow the code to do all the work by creating new sheets for each person that you may add to your list in Column A plus transfer the relevant data to each individual's sheet. Hence, the following code may be more beneficial for you:-


Option Explicit

Sub CreateSheetsTransferData()
        Dim ar As Variant
        Dim i As Integer
        Dim lr As Long
        Dim ws As Worksheet
        Dim sh As Worksheet

Application.ScreenUpdating = False

lr = Range("A" & Rows.Count).End(xlUp).Row

ar = Sheet1.Range("A2", Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp))
Set sh = Sheet1

For i = LBound(ar) To UBound(ar)
        If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then
        Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1)
        End If
        Set ws = Worksheets(CStr(ar(i, 1)))
        sh.Range("A1:A" & lr).AutoFilter 1, ar(i, 1)
        sh.[A1].CurrentRegion.Copy ws.[A1]
        ws.Columns.AutoFit
  Next i
    
sh.[A2].AutoFilter
Application.CutCopyMode = False
Application.ScreenUpdating = True
sh.Select
MsgBox "Sheets created/data transfer completed!", vbExclamation, "STATUS"

End Sub

This code will create sheets for any name in Column A of your Main sheet (without duplication) and transfer the relevant rows of data to each individual sheet. Your name list can grow as long as you need it to and the code will take care of the rest for you.

Following is the link to my updated test work book:-

https://www.dropbox.com/s/q1148n898kiy9xl/Maxi%28Master%20sht%20to%20multi%2C%20autofilter%2C%20array%292.xlsm?dl=0

Click on the "RUN" button to see it work for the names already in Column A then add some more names to suit yourself and click on the "RUN" button again to see new sheets added with their relevant data. 

With this method, you won't have to create new sheets manually. The code will do this for you as the need arises.

I hope that this helps.

Cheerio,
vcoolio.

maxi · Answer

Hello Vcoolio,

Many thanks once again and sorry for my late reply. Your macro is great and it does what I wanted to do. I am just thinking whether it is possible to do a bit more selective copying. 

So basically the same example, person A, B, and C. Each of them now has extra columns called info 1, 2, 3 and 4. And now the Data 1, 2, and 3 is a Yes or No entry. So for example, Person A is YES in Data 1 and 2, Person B is Yes in Data 2 only, and Person C is Yes in Data 2 and 3. 

Is it possible to make the sheet as Data 1, Data 2 and Data 3 (or even more when the database is expanded?) , and within each sheet, say Data 1 sheet, it will show Person A and the corresponding Info1, 2, 3 and 4? In Data 2 sheet, it will show Person A, Person B and Person C and their corresponding Info 1-4? Data 3 sheet, it will show Person C and the corresponding Info 1-4?

Sorry for keep asking. I really appreciate your help and your macro works great!

Many thanks
Maxi

vcoolio · Answer

Hello Maxi,

I'm a little confused as to what you would like to do so, for the sake of clarity, could you please upload a sample of your work book to a free file sharing site such as DropBox, ge.tt or SpeedyShare and then post the link to your file back here. Please use dummy data.

Add some notes to your work book clearly stating what you would like to do and we should then be able to sort it out for you.

Cheerio,
vcoolio.

maxi · Answer

Hello vcoolio

I am very sorry for the confusion. I have made up a excel file which I hope it is easier to understand. Like before, I only wish to enter data into the Main Sheet, then use macro to automatically select the data and copy into the corresponding Data 1, 2 or 3.

https://www.dropbox.com/s/1vbse5lae7cvzoi/maxi.xlsx?dl=0

Thank you very much.
maxi

vcoolio · Answer

Hello Maxi,

I'm still none the wiser.

Do you now want the sheets named Data1, Data2, Data3 etc. instead of the persons' name?

Why are the three names (Person A, Person B, Person C) all in one sheet (Data2)? I thought that you wanted them separate. Or has this something to do with the Yes/No criteria in columns H, I, J in your sample? This is completely different to your opening post.

Please explain your intentions further.

Cheerio,
vcoolio.

vcoolio · Answer

Hello again Maxi,

Reading through your posts again, perhaps you mean this:-

https://www.dropbox.com/s/p4mt9u20cs0rxl7/Maxi%283%29.xlsm?dl=0

Click on the "RUN" button in the sample at the above link to see if this is what you are wanting to do.
I've cleared the three "Data" sheets so that you can see more clearly how the code works.

The code for the above sample is as follows:-

Sub TransferData()

Dim lr As Long
    Dim i As Integer
    Dim ws As Worksheet
lr = Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name <> "Main sheet" Then ws.UsedRange.Offset(1).ClearContents
Next ws

For i = 2 To lr
    If Cells(i, 8).Value = "Yes" Then
      Range(Cells(i, 1), Cells(i, 6)).Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
        End If
        
    If Cells(i, 9).Value = "Yes" Then
      Range(Cells(i, 1), Cells(i, 6)).Copy Sheet3.Range("A" & Rows.Count).End(3)(2)
        End If
    
    If Cells(i, 10).Value = "Yes" Then
      Range(Cells(i, 1), Cells(i, 6)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2)
        End If
Next

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

This code doesn't create the sheets but relies on the User having already created them.

The code also won't allow duplicates.

I hope that this helps.

Cheerio,
vcoolio.

maxi · Answer

Hello vocclio,

That is perfect, it does exactly what I want to do. Thank you so much!!

I have a question, if in the future the database expands, i.e. more sheets (Data 4, Data 5 .... etc) and more Info (info 5, info 6 etc) and more person (Person D, E, F etc). What part of your code I need to change?

I have tried to create the sheet manually as you have mentioned but it does not copy the content into the Data D sheet that I have tried to test. Likewise, it seems the current code does not do beyond Person C, Info 4 and Data 3?

Many thanks once again.
Maxi

vcoolio · Answer

Hello Maxi,

Ok. If you expect that your data set may eventually grow to be very large, it may be best to go back to using the autofilter rather than a loop type code as per my post #8.

Hence, the following may be a better option:-

Sub TransferData()

Dim ws As Worksheet

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name <> "Main sheet" Then ws.UsedRange.Offset(1).ClearContents
Next ws

Sheet1.Range("H1", Sheet1.Range("H" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
[H1].AutoFilter

Sheet1.Range("I1", Sheet1.Range("I" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet3.Range("A" & Rows.Count).End(3)(2)
[I1].AutoFilter

Sheet1.Range("J1", Sheet1.Range("J" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2)
[J1].AutoFilter

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

However, based on the set-up of your main worksheet, if you add more Data columns (say Data 4, Data 5 etc.), you'll need to add more code "blocks" as above. So, if you add one more Data column (say Data 4 which will be column K), then a code "block" as follows will take care of the new column:-

Sheet1.Range("K1", Sheet1.Range("K" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2)
[K1].AutoFilter

You'll see that the column reference has been changed to "K" for this "block" and hence the pattern will repeat as you need to add more columns and more data "blocks".

If you add more Info columns (Info 5, Info 6 etc.) then you'll need to change the cell references in the following line of code in each "block":-

Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2)

This is the copy line of code so you only need to change the "F" to "K" or "L" or "M" etc. in each "block" depending on how many more Info columns that you add. This will copy an entire row from Column A out to whatever column you require which also means that any newly added Person will be copied/pasted to the relevant sheet based on the criteria "Yes" in the Data columns.

Following is the link to my updated test work book:-

https://www.dropbox.com/s/08vlgltpitx4z5z/Maxi%284%29.xlsm?dl=0https://www.dropbox.com/s/08vlgltpitx4z5z/Maxi%284%29.xlsm?dl=0

I've placed about 11,500 rows of data in it just to show how quickly autofilter will process the data.

I hope that this helps.

Cheerio,
vcoolio.

maxi · Answer

Hi vcoolio

That's is excellent! Thank you very much and it is very quick!! Thank you so much. You are brilliant.

I have tried to add Data 4 and it is good. However when I tried to add Info 5 and changed the code, it doesn't work. Have a look at my file, it seems the copy selection has shifted (see sheet Data 1)?! Did I put the coding wrong? 

https://www.dropbox.com/s/ynqa7d0li6hj5sx/Maxi-Info5.xlsm?dl=0
Thanks
Maxi

vcoolio · Answer

Hello Maxi,

As you have moved the data further to the right, you also need to change the cell references for the "Data" columns, as explained in my last post. Thus, the code should look as follows:-

Sub TransferData()

Dim ws As Worksheet

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name <> "Main sheet" Then ws.UsedRange.Offset(1).ClearContents
Next ws

Sheet1.Range("I1", Sheet1.Range("I" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
Sheet1.Range("A2", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
[I1].AutoFilter

Sheet1.Range("J1", Sheet1.Range("J" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
Sheet1.Range("A2", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet3.Range("A" & Rows.Count).End(3)(2)
[J1].AutoFilter

Sheet1.Range("K1", Sheet1.Range("K" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
Sheet1.Range("A2", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2)
[K1].AutoFilter

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

You can see that lines 11, 15, 17, 21, 23 & 27 in the above code have the new cell references.

As you add more columns of data, you need to keep an eye on the code cell references as previously explained.

Cheerio,
vcoolio.

Maxi · Answer

Hello vcoolio,

Many thanks, that's work very well. Thanks once again.

I am just trying out different things, and found that, for example, if I only have some values under Info 4 for 10 person, out of 100 person in total. When I do the "Run", it will only copy those 10 person with all the info cells filled in with something, even though the Data cells are "Yes". Is it normal?

A link for a quick look at the output
https://www.dropbox.com/s/06e79mg5r2khf24/Maxi%284%29.xlsm?dl=0

Thanks
Maxi

vcoolio · Answer

Hello Maxi,

If you expect to have varying cells without data then we need to modify the code again as follows:-

Option Explicit
Sub TransferData()

Dim ws As Worksheet
    Dim lr As Long
    
Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name <> "Main sheet" Then ws.UsedRange.Offset(1).ClearContents
Next ws

Sheet1.Range("I1", Sheet1.Range("I" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
    lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
      Sheet1.Range("A2:G" & lr).Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
        [I1].AutoFilter

Sheet1.Range("J1", Sheet1.Range("J" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
    lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
      Sheet1.Range("A2:G" & lr).Copy Sheet3.Range("A" & Rows.Count).End(3)(2)
        [J1].AutoFilter

Sheet1.Range("K1", Sheet1.Range("K" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
    lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
      Sheet1.Range("A2:G" & lr).Copy Sheet4.Range("A" & Rows.Count).End(3)(2)
        [K1].AutoFilter

Sheet1.Range("L1", Sheet1.Range("L" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7
    lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
      Sheet1.Range("A2:G" & lr).Copy Sheet5.Range("A" & Rows.Count).End(3)(2)
        [L1].AutoFilter

MsgBox "Data transfer completed!", vbExclamation

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

This will take care of the issue you mentioned in your last post and will also cover the prospect of blank cells in any data column.

Following is the link to the updated test work book:-

https://www.dropbox.com/s/3gd3u46ps7w6008/Maxi%285%29.xlsm?dl=0

Just remember to keep an eye on the cell references should you add any further columns in future.

I think that we have your query fully covered now.

Cheerio,
vcoolio.

Autocopy selected content from 1 sheet to another sheet

14 responses

Subscribe To Our Newsletter!