Need help on a macro.

[M15tyw00d]

I need a macro that I can connect to a button.

The macro would need to copy from the previous sheet in the same work book and paste to the worksheet with the button. I have a workbook per month and within each workbook I have a worksheet for each day of the month. So this button will be on each worksheet. So each day they will click the button and the following will occur.

MOVING CURRENT PATIENT INFORMATION FROM PREVIOUS DAY TO CURRENT DAY
copy B7:F26 previous sheet - paste B7:F26 current sheet
copy I7:J26 previous sheet - paste I7:J26 current sheet

copy M7:Q26 previous sheet - paste M7:Q26 current sheet
copy T7:U26 previous sheet - paste T7:U26 current sheet

ADDING PREVIOUS DAY'S ADMISSIONS TO CURRENT DAY
If (on previous sheet) B35 = Barney then copy C35:E35 and paste in first empty row in C7:E26 (This repeats for B35:B39)
If (on previous sheet) B35 = Denis then copy C35:E35 and paste in first empty row in N7:P26 (This repeats for B35:B39)
If (on previous sheet) M35 = Barney then copy N35:P35 and paste in first empty row in C7:E26 (This repeats for M35:M39)
If (on previous sheet) M35 = Denis then copy N35:P35 and paste in first empty row in N7:P26 (This repeats for M35:M39)

MOVING CURRENT DAY'S DISMISSALS OUT OF THE CENSUS AND INTO THE DISCHARGE AREA
On current sheet,
If J7=I1 then copy B7:F7 and paste in first empty row in range B28:F33 then clear contents in B7:F7 This is for the rows J7:J26
If U7=I1 then copy M7:Q7 and paste in first empty row in range M28:Q33 then clear contents in M7:Q7 This is for the rows U7:U26

PUTTING THE CURRENT PATIENTS IN ALPHA ORDER
sort B7:J26 by column C
sort M7:U26 by column N

FYI All cells are locked and protected (w/o a password) except B7:F26, I7:J26, M7:Q26, T7:U26, B28:F33, I28:I33, M28:Q33, T28:T33, B35:F39, I35:I39, M35:Q39, T35:T39.

Excel 2007

	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
5	INS		PATIENT	UD	ELOS				P	D/C		INS		PATIENT	UD	ELOS				P	D/C
6					Admit	Int.	Rem	Est Dis								Admit	Int.	Rem	Est Dis
7	1		X, Wanda		2-Jul			need LOS				1	PPK	X, Tammy	5-Jul	29-Jun			need LOS
8	2	WP	X, Raymond		13-Jun	29	9	11-Jul		13-Jul		2	OT	X, Carmine	29-Jun	26-Jun			need LOS		4 WKS
9	3		X, Willia		28-Jun			need LOS		ELOS - 7/10		3		X, Leonard		18-Jun	16	1	3-Jul		5-Jul
10	4	WP	X, Joshua		14-Jun	29	10	12-Jul		3-4 wks		4		X, Franklin		13-Jun	20	0	2-Jul		re eval
11	5	BC	X, Priscilla		2-Jul			need LOS				5		X, Joseph		28-Jun			need LOS		6-Jul
12	6		X, Raymond		25-Jun			need LOS		4 WKS		6	W	X, Dien		2-Jul			need LOS
13	7	W	X, Melvin		25-Jun			need LOS		2 WKS		7	PPK	X, Warren		2-Jul			need LOS
14	8		X, Mildred		15-Jun	22	4	6-Jul		6-Jul		8		X, Allen		19-Jun	34	20	22-Jul		reeval
15	9	BC	X, Quinton	5-Jul	29-Jun			need LOS				9	W	X, Ramon		21-Jun	23	11	13-Jul		reeval
16	10		X, Jerry		29-Jun			need LOS				10	J	X, Servendo		22-Jun	12	1	3-Jul		2 wks
17	11	PPK	X, Margarita	5-Jun	1-Jun	23	-9	23-Jun		2 wks		11	CO	X, Daryl	9-Jul	25-Jun			need LOS		6-Jul
18	12		X, Vicki		22-Jun	16	5	7-Jul		1-2 wks		12		X, Sharon		19-Jun	25	11	13-Jul		reeval
19	13											13
20	14											14
21	15											15
22	16											16
23	17											17
24	18											18
25	19											19
26	20											20
27			DISCHARGES																		1-Jan
28	1											1	CO	X, Daryl	9-Jul	25-Jun			need LOS		3-Jul
29	2											2
30	3											3
31	4											4
32	5											5
33	6											6
34			ADMITS																		0-Jan
35	1	Barney										6	Denis
36	2	Denis										7	Barney
37	3	Barney										8	Denis
38	4	Denis										9	Barney
39	5	Barney										10	Denis

<tbody>
</tbody>

07-03-12
​

 

[bertie]

Insert a command button
Select the developer tab
Select Controls => Insert => ActiveX
And place a command button on the sheet. (NB not the 1st of the month as there would be no "previous" sheet).

Double click the command button.

We can refer to worksheets by name, i.e., Worksheets("Sheet1"),
or by their index number, i.e., Worksheets(1)

We can us this to send the "current" worksheet to the main UpdateSheets() procedure, which will be located in Module1.

[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] [COLOR=#ff0000]CommandButton1[/COLOR]_Click()
   [COLOR=green]'pass the current worksheet(i) number to the update procedure[/COLOR]
   Module1.UpdateSheets Me.index
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

This code should in all sheets with a command button.
Only the CommandButton name, see highlighted, needs editing.

Insert Standard Module
In the VBA Editor window click Insert => Module
All of the following code goes into Module1

UpdateSheets() is the control procedure.
It calls other procedures as per your description.

[COLOR=darkblue]Sub[/COLOR] UpdateSheets([COLOR=darkblue]ByVal[/COLOR] index [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR])
   [COLOR=darkblue]Dim[/COLOR] wsPrev [COLOR=darkblue]As[/COLOR] Worksheet    [COLOR=green]'previous day worksheet[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] wsCurr [COLOR=darkblue]As[/COLOR] Worksheet    [COLOR=green]'next day worksheet[/COLOR]


   [COLOR=green]'handle working with worksheets(1), i.e., no prev worksheet[/COLOR]
   [COLOR=darkblue]If[/COLOR] index = 1 [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
   
   [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] errHandle
   
   [COLOR=darkblue]Set[/COLOR] wsCurr = Worksheets(index)
   [COLOR=darkblue]Set[/COLOR] wsPrev = Worksheets(index - 1)
      
   MovePatientInformation wsCurr, wsPrev
   AddAdmissions wsCurr, wsPrev
   MoveDismissals wsCurr
   SortData wsCurr, "B7:J26", "C7"
   SortData wsCurr, "M7:U26", "N7"
   
errHandle:
   [COLOR=darkblue]Set[/COLOR] wsCurr = [COLOR=darkblue]Nothing[/COLOR]
   [COLOR=darkblue]Set[/COLOR] wsPrev = [COLOR=darkblue]Nothing[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

MovePatientInformation()
Personally, I would copy the previous days worksheet. This would have the additional bonus of only working with one worksheet,

This is just a copy and paste effort so I will just post the code:

[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] MovePatientInformation([COLOR=darkblue]ByVal[/COLOR] wsCurr [COLOR=darkblue]As[/COLOR] Worksheet, _
                                   [COLOR=darkblue]ByVal[/COLOR] wsPrev [COLOR=darkblue]As[/COLOR] Worksheet)
   [COLOR=green]'========================================[/COLOR]
   [COLOR=green]'MOVING CURRENT PATIENT INFORMATION FROM[/COLOR]
   [COLOR=green]'PREVIOUS DAY TO CURRENT DAY[/COLOR]
   [COLOR=green]'========================================[/COLOR]
   wsPrev.Range("B7:F26").Copy Destination:=wsCurr.Range("B7")
   wsPrev.Range("I7:J26").Copy Destination:=wsCurr.Range("I7")
   wsPrev.Range("M7:Q26").Copy Destination:=wsCurr.Range("M7")
   wsPrev.Range("T7:U26").Copy Destination:=wsCurr.Range("T7")
   
   Application.CutCopyMode = [COLOR=darkblue]False[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

AddAmissions()
This procedure loops through rows 35-39 inclusive.

There are two functions associated with this procedure:

GetPasteColumn()
I have isolated this in a Select Case statement in case you need to add any more staff members.

[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Function[/COLOR] GetPasteColumn([COLOR=darkblue]ByVal[/COLOR] sStaff [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]) [COLOR=darkblue]As[/COLOR] String
   [COLOR=green]'=============================================[/COLOR]
   [COLOR=green]'Returns paste column letter[/COLOR]
   [COLOR=green]'==============================================[/COLOR]
   [COLOR=darkblue]Select[/COLOR] [COLOR=darkblue]Case[/COLOR] sStaff
      [COLOR=darkblue]Case[/COLOR] "BARNEY"
         GetPasteColumn = "C"
      [COLOR=darkblue]Case[/COLOR] [COLOR=darkblue]Else[/COLOR] [COLOR=green]'DENNIS[/COLOR]
         GetPasteColumn = "N"
   [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Select[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Function[/COLOR]

GetLastRow()
This is used by a couple of procedures to get the next available row in a particular column.

[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Function[/COLOR] GetLastRow([COLOR=darkblue]ByVal[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet, _ 
                           [COLOR=darkblue]ByVal[/COLOR] sAddress [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]) [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] rng [COLOR=darkblue]As[/COLOR] Range
   
   [COLOR=darkblue]Set[/COLOR] rng = ws.Range(sAddress)
   [COLOR=darkblue]Do[/COLOR] [COLOR=darkblue]Until[/COLOR] rng = ""
      [COLOR=darkblue]Set[/COLOR] rng = rng.Offset(1, 0)
   [COLOR=darkblue]Loop[/COLOR]
   
   GetLastRow = rng.Row
   [COLOR=darkblue]Set[/COLOR] rng = [COLOR=darkblue]Nothing[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Function[/COLOR]

The AddAmissions() procedure processes column B then column M and processes the data based on the staff member's name.

[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] AddAdmissions([COLOR=darkblue]ByVal[/COLOR] wsCurr [COLOR=darkblue]As[/COLOR] Worksheet, _
                          [COLOR=darkblue]ByVal[/COLOR] wsPrev [COLOR=darkblue]As[/COLOR] Worksheet)
   [COLOR=green]'===============================================[/COLOR]
   [COLOR=green]'ADDING PREVIOUS DAY'S ADMISSIONS TO CURRENT DAY[/COLOR]
   [COLOR=green]'===============================================[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] rw [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]                [COLOR=green]'loop index[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] lr [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]                'last row + 1
   [COLOR=darkblue]Dim[/COLOR] sCopyRange [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] sPasteCol [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]       [COLOR=green]'paste destination column[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] sStaffName [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]      [COLOR=green]'barney or Dennis[/COLOR]


   [COLOR=darkblue]For[/COLOR] rw = 35 [COLOR=darkblue]To[/COLOR] 39
      [COLOR=green]'========[/COLOR]
      'column B
      [COLOR=green]'========[/COLOR]
      lr = GetLastRow(wsCurr, "C7")
      [COLOR=darkblue]If[/COLOR] lr = 0 [COLOR=darkblue]Then[/COLOR] lr = 7
      
      sCopyRange = "C" & rw & ":E" & rw
      sStaffName = UCase(wsPrev.Range("B" & rw).Value)
      sPasteCol = GetPasteColumn(sStaffName)
      
      [COLOR=green]'copy and paste[/COLOR]
      wsPrev.Range(sCopyRange).Copy _
          Destination:=wsCurr.Range(sPasteCol & lr)
               
      [COLOR=green]'========[/COLOR]
      'column M
      [COLOR=green]'========[/COLOR]
      lr = GetLastRow(wsCurr, "N7")
      [COLOR=darkblue]If[/COLOR] lr = 0 [COLOR=darkblue]Then[/COLOR] lr = 7
      
      sCopyRange = "N" & rw & ":P" & rw
      sStaffName = UCase(wsPrev.Range("M" & rw).Value)
      sPasteCol = GetPasteColumn(sStaffName)
      
      [COLOR=green]'copy and paste[/COLOR]
      wsPrev.Range(sCopyRange).Copy _
          Destination:=wsCurr.Range(sPasteCol & lr)
   [COLOR=darkblue]Next[/COLOR] rw


   Application.CutCopyMode = [COLOR=darkblue]False[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

We are limited to the number of words per post and I must be running out. So I will just post the other procedures.

MoveDismissals()
Simply builds up the copy range and determine where to paste it.

[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] MoveDismissals([COLOR=darkblue]ByVal[/COLOR] wsCurr [COLOR=darkblue]As[/COLOR] Worksheet)   [COLOR=green]'==============================================[/COLOR]
   [COLOR=green]'MOVING CURRENT DAY'S DISMISSALS[/COLOR]
   [COLOR=green]'OUT OF THE CENSUS AND INTO THE DISCHARGE AREA[/COLOR]
   [COLOR=green]'==============================================[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] rw [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]       [COLOR=green]'loop index[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] lr [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]       'last row row + 1
   [COLOR=darkblue]Dim[/COLOR] sCopyRange [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   
   [COLOR=darkblue]For[/COLOR] rw = 7 [COLOR=darkblue]To[/COLOR] 26
      [COLOR=darkblue]With[/COLOR] wsCurr
      [COLOR=green]'========[/COLOR]
      'column B
      [COLOR=green]'========[/COLOR]
         [COLOR=darkblue]If[/COLOR] .Range("J" & rw).Value = .Range("I1").Value [COLOR=darkblue]Then[/COLOR]
            lr = GetLastRow(wsCurr, "C28")   [COLOR=green]'patient's name[/COLOR]
            [COLOR=darkblue]If[/COLOR] lr = 0 [COLOR=darkblue]Then[/COLOR] lr = 28
            
            [COLOR=green]'copy and paste, clear contents[/COLOR]
            sCopyRange = "B" & rw & ":F" & rw
            .Range(sCopyRange).Copy _
                  Destination:=.Range("B" & lr)
            .Range(sCopyRange).ClearContents
         [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
[COLOR=green]'Stop[/COLOR]
      '========
      [COLOR=green]'column M[/COLOR]
      '========
         [COLOR=darkblue]If[/COLOR] .Range("U" & rw).Value = .Range("I1").Value [COLOR=darkblue]Then[/COLOR]
            lr = GetLastRow(wsCurr, "N28")   [COLOR=green]'patient's name[/COLOR]
            [COLOR=darkblue]If[/COLOR] lr = 0 [COLOR=darkblue]Then[/COLOR] lr = 28
            
            [COLOR=green]'copy and paste, clear contents[/COLOR]
            sCopyRange = "M" & rw & ":Q" & rw
            .Range(sCopyRange).Copy _
                  Destination:=.Range("M" & lr)
            .Range(sCopyRange).ClearContents
         [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
      
   [COLOR=darkblue]Next[/COLOR] rw
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

SortData()

[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] SortData([COLOR=darkblue]ByVal[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet, _                     [COLOR=darkblue]ByVal[/COLOR] sRange [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR], _
                     [COLOR=darkblue]ByVal[/COLOR] sKey [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR])
   
   ws.Range(sRange).Sort _
        Key1:=ws.Range(sKey)
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

NB Make a copy of your workbook before testing the code.

I appreciate this is a lot to take in. Feel free to ask for any clarification of the code.

If you would like a copy of the file I worked on the please send me a pm with your email address.

Bertie

 

[M15tyw00d]

OMG! Thank you so much. Finally had a chance to check it out! It worked great.

When I ran it as a test I noticed that for some reason when it moved row 8, it only copied B8 and F8. It skipped C8:E8. It did it for every other row perfect. Maybe just a weird glitch and it won't do it on the next pages... I just copied those cells and resorted manually. Looking at the code, there was no reason for it not to copy. I am going to add it to another page in the test worksheet and see if it does it again. You are a genius!

Also. Could we tweak the code so that when it moves current days dismissals, it only moves "B" through "F" and when it clears contents it clears "B" through "J"?

The code works amazingly!

 

[M15tyw00d]

Ok I tested it again. In the area where it moves the new admissions over, "Barney was first, it moved it; Denis was second, it did not move it; Barney was third and it did not move it.

Here is a link to the test sheet I have. https://www.box.com/s/abf8159d1525405de648

 

[bertie]

I have made the following adjustments:

UpdateSheet() Procedure
I have changed the designations of the worksheets:

   [COLOR=darkblue]Set[/COLOR] wsCurr = Worksheets(index + 1)
   [COLOR=darkblue]Set[/COLOR] wsPrev = Worksheets(index)

AddAdmissions() Procedure.
I have amended the order in which we determine the last row and paste column.
e.g. For column B:

      [COLOR=green]'========[/COLOR]
      'column B
      [COLOR=green]'========[/COLOR]
      sStaffName = UCase(wsPrev.Range("B" & rw).Value)
      sPasteCol = GetPasteColumn(sStaffName)
      lr = GetLastRow(wsCurr, sPasteCol & "7")

MoveDismissals() Procedure
I have added another line to adjust the ClearContents range:
e.g., For column B:

            [COLOR=green]'copy and paste, clear contents[/COLOR]
            sCopyRange = "B" & rw & ":F" & rw
            .Range(sCopyRange).Copy _
                  Destination:=.Range("B" & lr)
[COLOR=#ff0000]            sCopyRange = "B" & rw & ":J" & rw[/COLOR]
            .Range(sCopyRange).ClearContents

The full amended code is below. Try this:

[COLOR=darkblue]Sub[/COLOR] UpdateSheets([COLOR=darkblue]ByVal[/COLOR] index [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR])
   [COLOR=darkblue]Dim[/COLOR] wsPrev [COLOR=darkblue]As[/COLOR] Worksheet    [COLOR=green]'previous day worksheet[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] wsCurr [COLOR=darkblue]As[/COLOR] Worksheet    [COLOR=green]'next day worksheet[/COLOR]

    [COLOR=green]'handle working with worksheets(1), i.e., no prev worksheet[/COLOR]
   [COLOR=darkblue]If[/COLOR] index = 1 [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Exit[/COLOR] [COLOR=darkblue]Sub[/COLOR]
   
   [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] errHandle
   
   [COLOR=darkblue]Set[/COLOR] wsCurr = Worksheets(index + 1)
   [COLOR=darkblue]Set[/COLOR] wsPrev = Worksheets(index)
      
   MovePatientInformation wsCurr, wsPrev
   AddAdmissions wsCurr, wsPrev
   MoveDismissals wsCurr
   SortData wsCurr, "B7:J26", "C7"
   SortData wsCurr, "M7:U26", "N7"
   
errHandle:
   [COLOR=darkblue]Set[/COLOR] wsCurr = [COLOR=darkblue]Nothing[/COLOR]
   [COLOR=darkblue]Set[/COLOR] wsPrev = [COLOR=darkblue]Nothing[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]



[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] MovePatientInformation([COLOR=darkblue]ByVal[/COLOR] wsCurr [COLOR=darkblue]As[/COLOR] Worksheet, _
                                   [COLOR=darkblue]ByVal[/COLOR] wsPrev [COLOR=darkblue]As[/COLOR] Worksheet)
   [COLOR=green]'========================================[/COLOR]
   [COLOR=green]'MOVING CURRENT PATIENT INFORMATION FROM[/COLOR]
   [COLOR=green]'PREVIOUS DAY TO CURRENT DAY[/COLOR]
   [COLOR=green]'========================================[/COLOR]
   wsPrev.Range("B7:F26").Copy Destination:=wsCurr.Range("B7")
   wsPrev.Range("I7:J26").Copy Destination:=wsCurr.Range("I7")
   wsPrev.Range("M7:Q26").Copy Destination:=wsCurr.Range("M7")
   wsPrev.Range("T7:U26").Copy Destination:=wsCurr.Range("T7")
   
   Application.CutCopyMode = [COLOR=darkblue]False[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub
[/COLOR]


[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Function[/COLOR] GetPasteColumn([COLOR=darkblue]ByVal[/COLOR] sStaff [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]) [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=green]'=============================================[/COLOR]
   [COLOR=green]'Returns paste column letter[/COLOR]
   [COLOR=green]'==============================================[/COLOR]
   [COLOR=darkblue]Select[/COLOR] [COLOR=darkblue]Case[/COLOR] sStaff
      [COLOR=darkblue]Case[/COLOR] "BARNEY"
         GetPasteColumn = "C"
      [COLOR=darkblue]Case[/COLOR] [COLOR=darkblue]Else[/COLOR] [COLOR=green]'DENNIS[/COLOR]
         GetPasteColumn = "N"
   [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Select[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Function
[/COLOR]


[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Function[/COLOR] GetLastRow([COLOR=darkblue]ByVal[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet, _
                           [COLOR=darkblue]ByVal[/COLOR] sAddress [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]) [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] rng [COLOR=darkblue]As[/COLOR] Range
   
   [COLOR=darkblue]Set[/COLOR] rng = ws.Range(sAddress)
   [COLOR=darkblue]Do[/COLOR] [COLOR=darkblue]Until[/COLOR] rng = ""
      [COLOR=darkblue]Set[/COLOR] rng = rng.Offset(1, 0)
   [COLOR=darkblue]Loop[/COLOR]
   
   GetLastRow = rng.Row
   [COLOR=darkblue]Set[/COLOR] rng = [COLOR=darkblue]Nothing[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Function
[/COLOR]


[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] AddAdmissions([COLOR=darkblue]ByVal[/COLOR] wsCurr [COLOR=darkblue]As[/COLOR] Worksheet, _
                          [COLOR=darkblue]ByVal[/COLOR] wsPrev [COLOR=darkblue]As[/COLOR] Worksheet)
   [COLOR=green]'===============================================[/COLOR]
   [COLOR=green]'ADDING PREVIOUS DAY'S ADMISSIONS TO CURRENT DAY[/COLOR]
   [COLOR=green]'===============================================[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] rw [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]                [COLOR=green]'loop index[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] lr [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]                'last row + 1
   [COLOR=darkblue]Dim[/COLOR] sCopyRange [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] sPasteCol [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]       [COLOR=green]'paste destination column[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] sStaffName [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]      [COLOR=green]'barney or Dennis[/COLOR]




   [COLOR=darkblue]For[/COLOR] rw = 35 [COLOR=darkblue]To[/COLOR] 39
      [COLOR=green]'========[/COLOR]
      'column B
      [COLOR=green]'========[/COLOR]
      sStaffName = UCase(wsPrev.Range("B" & rw).Value)
      sPasteCol = GetPasteColumn(sStaffName)
      lr = GetLastRow(wsCurr, sPasteCol & "7")
      [COLOR=darkblue]If[/COLOR] lr = 0 [COLOR=darkblue]Then[/COLOR] lr = 7
      sCopyRange = "C" & rw & ":E" & rw
      [COLOR=green]'copy and paste[/COLOR]
      wsPrev.Range(sCopyRange).Copy _
          Destination:=wsCurr.Range(sPasteCol & lr)
               
      [COLOR=green]'========[/COLOR]
      'column M
      [COLOR=green]'========[/COLOR]
      sStaffName = UCase(wsPrev.Range("M" & rw).Value)
      sPasteCol = GetPasteColumn(sStaffName)
      lr = GetLastRow(wsCurr, sPasteCol & "7")
      [COLOR=darkblue]If[/COLOR] lr = 0 [COLOR=darkblue]Then[/COLOR] lr = 7
      sCopyRange = "N" & rw & ":P" & rw
      [COLOR=green]'copy and paste[/COLOR]
      wsPrev.Range(sCopyRange).Copy _
          Destination:=wsCurr.Range(sPasteCol & lr)
   [COLOR=darkblue]Next[/COLOR] rw

   Application.CutCopyMode = [COLOR=darkblue]False[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub
[/COLOR]


[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] MoveDismissals([COLOR=darkblue]ByVal[/COLOR] wsCurr [COLOR=darkblue]As[/COLOR] Worksheet)   [COLOR=green]'==============================================[/COLOR]
   [COLOR=green]'MOVING CURRENT DAY'S DISMISSALS[/COLOR]
   [COLOR=green]'OUT OF THE CENSUS AND INTO THE DISCHARGE AREA[/COLOR]
   [COLOR=green]'==============================================[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] rw [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]       [COLOR=green]'loop index[/COLOR]
   [COLOR=darkblue]Dim[/COLOR] lr [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]       'last row row + 1
   [COLOR=darkblue]Dim[/COLOR] sCopyRange [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
   
   [COLOR=darkblue]For[/COLOR] rw = 7 [COLOR=darkblue]To[/COLOR] 26
      [COLOR=darkblue]With[/COLOR] wsCurr
      [COLOR=green]'========[/COLOR]
      'column B
      [COLOR=green]'========[/COLOR]
         [COLOR=darkblue]If[/COLOR] .Range("J" & rw).Value = .Range("I1").Value [COLOR=darkblue]Then[/COLOR]
            lr = GetLastRow(wsCurr, "C28")   [COLOR=green]'patient's name[/COLOR]
            [COLOR=darkblue]If[/COLOR] lr = 0 [COLOR=darkblue]Then[/COLOR] lr = 28
            
            [COLOR=green]'copy and paste, clear contents[/COLOR]
            sCopyRange = "B" & rw & ":F" & rw
            .Range(sCopyRange).Copy _
                  Destination:=.Range("B" & lr)
            sCopyRange = "B" & rw & ":J" & rw
            .Range(sCopyRange).ClearContents
         [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
[COLOR=green]'Stop[/COLOR]
      '========
      [COLOR=green]'column M[/COLOR]
      '========
         [COLOR=darkblue]If[/COLOR] .Range("U" & rw).Value = .Range("I1").Value [COLOR=darkblue]Then[/COLOR]
            lr = GetLastRow(wsCurr, "N28")   [COLOR=green]'patient's name[/COLOR]
            [COLOR=darkblue]If[/COLOR] lr = 0 [COLOR=darkblue]Then[/COLOR] lr = 28
            
            [COLOR=green]'copy and paste, clear contents[/COLOR]
            sCopyRange = "M" & rw & ":Q" & rw
            .Range(sCopyRange).Copy _
                  Destination:=.Range("M" & lr)
            sCopyRange = "M" & rw & ":U" & rw
            .Range(sCopyRange).ClearContents
         [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
      
   [COLOR=darkblue]Next[/COLOR] rw
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub
[/COLOR]


[COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] SortData([COLOR=darkblue]ByVal[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet, _
                    [COLOR=darkblue]ByVal[/COLOR] sRange [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR], _
                     [COLOR=darkblue]ByVal[/COLOR] sKey [COLOR=darkblue]As[/COLOR] String)
   
   ws.Range(sRange).Sort _
        Key1:=ws.Range(sKey)
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

 

[M15tyw00d]

I am sooooo happy right now!!!! Thank you soooooo very much! This is amazing! It works perfect!

I know I have asked so much already, but is there a way that on the first of the month (since there is not a 'previous worksheet') the import button can pull information from the last worksheet of the previous month workbook? Each workbook is labeled with 4 digit year space full month name.xlsm (if case sensitive, then the months only have the first letter capitalized). Thank you so much.

 

[M15tyw00d]

oh no! I tested it on the 8th, it worked. Though it did not show anything until I clicked on another sheet then back to that one. It did work though. Then I went to the 7th and tested it. It did not work. Since it did not pull any information I also noticed that it auto updated the 8th to show no information either... Not for sure why...

 

[bertie]

OK, you have lost me. Don't worry, it's not that hard to do.

Currently we assign worksheets to variables using their index number:

wsPrevious = Worksheets(index)
wsCurrent =Worksheets(index + 1)​

This depends on the worksheets being in linear order and being processed one after the other.

I am going to advocate a simpler approach to your problem; one that means we work with one worksheet rather than copying and pasting between two. It should also simplify, in my opinion, carrying over values between months.

How about:
At the end of each month the INSERT button:

Saves the file as a new workbook.
Deletes all but the last worksheet - renaming it as first day of the new month.​

At the end of each day the INSERT button:

Copies the last worksheet - renaming it for the next day.

​

This removes all need for copying and pasting, and we only need code to tidy up and clear out unwanted entries in the newly created worksheet. We could probably code this within one procedure.

Your thoughts please.
Bertie

 

[M15tyw00d]

ok. I would have to see it working. I am too visual. There would still be copy & past but within the same worksheet I guess. Because the new admits would still need to move up and clear and the discharges need to move down and clear.

Did it mess up due to going backward? using the button on the 7th then trying to go back and running it on the 6th?

 

[M15tyw00d]

oh, Also this could not work. I have code that runs for the previous page that I have to set up in advance for the fiscal year. If you look at my file, in the top part of each sheet you will see that the Admissions YTD updates everyday it adds the previous days YTD and previous days admissions so it has a running total of the year. It takes me a few weeks each year to get all the sheets ready for the fiscal year. There are 8 such codes dependent on the day before. There is also a pivot table that is set to update automatically based on those calculations. This is all set up once a year.

If you can look over the sheet and find a better way to do this that would be great.

I have a code that I use once a year that creates the sheets for each day of the year.

Option Explicit

Sub prCreateSheets()

Dim rng             As Range
Dim rngC            As Range

Dim wsCopy          As Worksheet

Set rng = Range("Z2:Z366")

For Each rngC In rng.Cells

    If rngC.Value <> "" Then
    
        Set wsCopy = ActiveWorkbook.Worksheets("Master Stat")
        wsCopy.Copy After:=Worksheets(Worksheets.Count)
        
        'Add error handling in case sheet with this name already exists
        On Error Resume Next
            ActiveSheet.Name = Format(rngC.Value, "mm-dd-yy")
        On Error GoTo 0
        
        ActiveSheet.Range("H1").Value = Format(rngC.Value, "mm-dd-yy")
        
    End If

Next rngC

End Sub

Then I have to go through and move each month into its own workbook. Then I have to go through each day and update the formulas to read the right worksheet. It is tedious.