# Need help on a macro.

#### M15tyw00d

##### Active Member
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

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
ABCDEFGHIJKLMNOPQRSTU
5INSPATIENTUDELOSPD/CINSPATIENTUDELOSPD/C
71X, Wanda2-Julneed LOS1PPKX, Tammy5-Jul29-Junneed LOS
82WPX, Raymond13-Jun29911-Jul13-Jul2OTX, Carmine29-Jun26-Junneed LOS4 WKS
93X, Willia28-Junneed LOSELOS - 7/103X, Leonard18-Jun1613-Jul5-Jul
104WPX, Joshua14-Jun291012-Jul3-4 wks4X, Franklin13-Jun2002-Julre eval
115BCX, Priscilla2-Julneed LOS5X, Joseph28-Junneed LOS6-Jul
126X, Raymond25-Junneed LOS4 WKS6WX, Dien2-Julneed LOS
137WX, Melvin25-Junneed LOS2 WKS7PPKX, Warren2-Julneed LOS
148X, Mildred15-Jun2246-Jul6-Jul8X, Allen19-Jun342022-Julreeval
159BCX, Quinton5-Jul29-Junneed LOS9WX, Ramon21-Jun231113-Julreeval
1610X, Jerry29-Junneed LOS10JX, Servendo22-Jun1213-Jul2 wks
1711PPKX, Margarita5-Jun1-Jun23-923-Jun2 wks11COX, Daryl9-Jul25-Junneed LOS6-Jul
1812X, Vicki22-Jun1657-Jul1-2 wks12X, Sharon19-Jun251113-Julreeval
191313
201414
211515
221616
231717
241818
251919
262020
27DISCHARGES1-Jan
2811COX, Daryl9-Jul25-Junneed LOS3-Jul
2922
3033
3144
3255
3366
351Barney6Denis
362Denis7Barney
373Barney8Denis
384Denis9Barney
395Barney10Denis

<tbody>
</tbody>
07-03-12

### Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.

#### bertie

##### Well-known Member
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.
Code:
``````[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]
[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

It calls other procedures as per your description.
Code:
``````[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
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:
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]``````

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.
Code:
``````[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.
Code:
``````[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]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.
Code:
``````[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]'===============================================[/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.
Code:
``````[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()
Code:
``````[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.

Bertie

#### M15tyw00d

##### Active Member
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

##### Active Member
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

##### Well-known Member

I have changed the designations of the worksheets:
Code:
``````   [COLOR=darkblue]Set[/COLOR] wsCurr = Worksheets(index + 1)
[COLOR=darkblue]Set[/COLOR] wsPrev = Worksheets(index)``````

I have amended the order in which we determine the last row and paste column.
e.g. For column B:
Code:
``````      [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
e.g., For column B:
Code:
``````            [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:
Code:
``````[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
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]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]ByVal[/COLOR] wsPrev [COLOR=darkblue]As[/COLOR] Worksheet)
[COLOR=green]'===============================================[/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

##### Active Member
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

##### Active Member
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

##### Well-known Member
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.

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.

Bertie

#### M15tyw00d

##### Active Member
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

##### Active Member
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.

Code:
``````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)

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.

Replies
15
Views
284
Replies
6
Views
159
Replies
4
Views
200
Replies
4
Views
181
Replies
0
Views
157

1,195,673
Messages
6,011,087
Members
441,582
Latest member
Topkapi

### 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.

### Which adblocker are you using?

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

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