Using VBA to Copy Data/Remove Data across Sheets

sssyntax

New Member
Joined
Jan 10, 2018
Messages
2
Hello Excel Community -

I am working on a project to centralize data that we collect onto a workbook. I have been looking around on different forums and websites to guide me on this but I have not had much luck. There is a master spreadsheet holding all crucial data with a face page sheet to have buttons to run all the macros I am going to set up, and here are some of the goals of the macros I would like to set up:

  1. Archiving Events -- essentially copy and pasting rows based on a the text within a cell (Complete/Cancelled) into an archive sheet, to show only current and up to date events on the master sheet
  2. Copying Rows based on different words onto their respective sheet for example: All 'sub type columns' will move from the master sheet into the breakdown sheet (this sheet is to essentially track events based on a specific disease type)
  3. Copying rows and only certain columns from each row into another sheet and to have it paste it several times depending on the number in one of the cells; example:

Master Disease Sheet
DateNameTimePresenterCompletedDisease Type# of cases presented
1/10/18Ovarian Overview6:00 pmDr. SmithCompleteOvarian5
1/10/18Prostate7:00 pmDr. ACompleteProstate3

<tbody>
</tbody>
--> the code would be written to move certain details from the row to another sheet for all disease specific events (Disease Type: Ovarian to move to sheet named: Ovarian, etc), and to look like this:
DateNamePresenterCase #Pt #Care PlanFollow UP Plan
1/10/18Ovarian OverviewDr. Smith1
1/10/18 Ovarian OverviewDr. Smith2
1/10/18Ovarian OverviewDr. Smith3
1/10/18Ovarian OverviewDr. Smith4
1/10/18Ovarian OverviewDr. Smith5

<tbody>
</tbody>

I have been following tutorials online for the coding mechanism but I am not having much luck. Any guidance on this would be really appreciated.

Thanks!
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
I can solve this for you. Working on a solution.

Please help to clarify the request by answering the questions below:

1. Are all activities occurring within one Workbook?
2. I need more of an explanation for your item # 2. You mention All 'sub type columns'. Is this referencing the different values in the Name column? Can you provide an example for this item?
 
Last edited:
Upvote 0
Here is code to Archive Data

Code:
Option Explicit


Sub Archive()
Dim cfws As Worksheet
Dim ctws As Worksheet
Dim i As Long
Dim lastrow As Long
Dim nextrow As Long
Dim status As String


Set cfws = Worksheets("Master")
Set ctws = Worksheets("Archive")
lastrow = cfws.Cells(cfws.Rows.Count, "A").End(xlUp).Row
nextrow = ctws.Cells(ctws.Rows.Count, "A").End(xlUp).Row + 1


For i = 2 To lastrow
    status = cfws.Cells(i, 5).Value
    Select Case status
    Case "Complete", "Cancelled"
        cfws.Range("A" & i & ":G" & i).Cut ctws.Range("A" & nextrow)
        Rows(i).EntireRow.Delete
        i = i - 1
        lastrow = lastrow - 1
        nextrow = nextrow + 1
    End Select
Next i


End Sub
 
Last edited:
Upvote 0
Here is code for the second item based on my understanding of what you are wanting to do which is:

This code can run either before or after the Archive module is executed, your call on when to run based on whether you want to copy Completed or Cancelled items to these new worksheets.

This code looks at each row on the Master Worksheet, takes the value in the Disease Type Column, determines if a Worksheet already exists and creates the Worksheet if it doesn't exist and then copies the row of data from Master to the next vacant row on the Disease specific Worksheet.

Let me know if that is not what you were wanting with Item 2.

Code:
Option Explicit


Sub CreateDiseaseType()


Dim ws As Worksheet
Dim cfws As Worksheet
Dim ctws As Worksheet
Dim i As Long
Dim lastrow As Long
Dim nextrow As Long
Dim SheetName As String
Dim SheetExists As Boolean


Set cfws = Worksheets("Master")
lastrow = cfws.Cells(cfws.Rows.Count, "A").End(xlUp).Row


For i = lastrow To 2 Step -1
    SheetExists = False
    SheetName = cfws.Cells(i, 6).Value
        For Each ws In Worksheets
            If SheetName = ws.Name Then
                SheetExists = True
            End If
        Next ws
    If SheetExists = False Then
        With ThisWorkbook
            Set ctws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            ctws.Name = SheetName
        End With
        cfws.Range("A1:G1").Copy ctws.Range("A1")
    End If
    nextrow = ctws.Cells(ctws.Rows.Count, "A").End(xlUp).Row + 1
    cfws.Range("A" & i & ":G" & i).Copy ctws.Range("A" & nextrow)
Next i


End Sub
 
Upvote 0
Here is the code for Item 3:
This code creates a new Worksheet based on the value in the Disease Type column then copies the data as requested and creates the number of rows based on the value in the "# of cases presented" column.

My assumption here is that there should never be more that one row per disease type. If that is not true let me know and I can modify that as needed.

Code:
Option Explicit


Sub CreateDiseaseSpecificCases()


Dim ws As Worksheet
Dim cfws As Worksheet
Dim ctws As Worksheet
Dim i As Long
Dim x As Long
Dim qty As Long
Dim lastrow As Long
Dim NextRow As Long
Dim SheetName As String
Dim SheetExists As Boolean


Set cfws = Worksheets("Master")
lastrow = cfws.Cells(cfws.Rows.Count, "A").End(xlUp).Row


For i = 2 To lastrow
    SheetExists = False
    SheetName = cfws.Cells(i, 6).Value & " Cases"
        For Each ws In Worksheets
            If SheetName = ws.Name Then
                SheetExists = True
                GoTo NextRow
            End If
        Next ws
    If SheetExists = False Then
        With ThisWorkbook
            Set ctws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            ctws.Name = SheetName
            ctws.Range("A1").Value = "Date"
            ctws.Range("B1").Value = "Name"
            ctws.Range("C1").Value = "Presenter"
            ctws.Range("D1").Value = "Case #"
            ctws.Range("E1").Value = "Pt #"
            ctws.Range("F1").Value = "Care Plan"
            ctws.Range("G1").Value = "Follow Up Plan"
        End With
    End If
    qty = cfws.Cells(i, 7).Value
    For x = 1 To qty
        NextRow = ctws.Cells(ctws.Rows.Count, "A").End(xlUp).Row + 1
        ctws.Range("A" & NextRow) = cfws.Range("A" & i)
        ctws.Range("B" & NextRow) = cfws.Range("B" & i)
        ctws.Range("C" & NextRow) = cfws.Range("D" & i)
        ctws.Range("D" & NextRow) = x
    Next x
    ctws.Range("A2", "A" & (qty + 2)).NumberFormat = "mm/dd/yy"
NextRow:
Next i


End Sub
 
Upvote 0
Upon a retest I determined the second code module had an error. Corrected code below.

Code:
Option Explicit


Sub CreateDiseaseType()


Dim ws As Worksheet
Dim cfws As Worksheet
Dim ctws As Worksheet
Dim i As Long
Dim lastrow As Long
Dim NextRow As Long
Dim SheetName As String
Dim SheetExists As Boolean


Set cfws = Worksheets("Master")
lastrow = cfws.Cells(cfws.Rows.Count, "A").End(xlUp).Row


For i = lastrow To 2 Step -1
    SheetExists = False
    SheetName = cfws.Cells(i, 6).Value
        For Each ws In Worksheets
            If SheetName = ws.Name Then
                SheetExists = True
                Set ctws = Worksheets(SheetName)
            End If
        Next ws
    If SheetExists = False Then
        With ThisWorkbook
            Set ctws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            ctws.Name = SheetName
        End With
        cfws.Range("A1:G1").Copy ctws.Range("A1")
    End If
    NextRow = ctws.Cells(ctws.Rows.Count, "A").End(xlUp).Row + 1
    cfws.Range("A" & i & ":G" & i).Copy ctws.Range("A" & NextRow)
Next i


End Sub
 
Upvote 0
Thank you so much frank_AL for your assistance on this and your coding, as for your questions:

1. All activities will be in this one workbook, the essential goal of it is to be a log for the current year - which then can be replicated for the next year for recording purposes.
2. So this is currently how the master calendar tracker sheet looks like:

DateTime StartTime EndTitleLocationTeleconference Available?TypeSub-TypeCommunityInvolvmentX Involvement?X MembersQuarterStatus
8-Jan8:00 AM9:00 AMClinical Research MeetingYClinical Research SubcommitteeBreast

<tbody>
</tbody>
We have a column labeled "Type"; and depending on if it is a certain type "A" or "B" it will be copied onto the sheet for 'Tumor Boards/Disease Management Teams' and to look like this (I removed the other columns to the right, as this information would be added once they have been copied over after the meeting/event is complete:

DateTitleTypeSub-TypeCommunityInvolvmentX Involvement?X Members#of CasesMemberPt Initials (& MRN)DiagnosisCase PresenterPathology Review
8-JanClinical Research MeetingClinical ResearchBreast

<tbody>
</tbody>

Hope this cleared the air -
 
Upvote 0
Please test the code I provided for Items 1 and 3 and provide feedback.

I'm still confused about Item 2.
In your response: We have a column labeled "Type"; and depending on if it is a certain type "A" or "B" it will be copied onto the sheet for 'Tumor Boards/Disease Management Teams'
What determines "if it is a
certain type "A" or "B"". Is there a table somewhere that can be used to test against? The row you show moving has "Clinical Research Subcommittee" so I don't know how to relate that to a type of "A" or "B".

Also, when that row is moved you then show Type to be "Clinical Research" which is shortened from "
Clinical Research Subcommittee". How would I determine how to shorten the various possibilities to get the desired result?

Let me know!
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top