Help required tidying up the code

[northrops]

Hi,
This is my first attempt at writing code from scratch without using the recorder.
The code does what I want it to do but I would like to know if there is a way of shortening it.

I need to extract data from a sheet and paste into individual location sheets.

I need the code to run in Excel 2003 and 2007.

The code looks up the location in the "Data" sheet, if the row is in group "S" then the data is copied and pasted into the relevant sheet against the correct week and day.

The Week and Day are selected from the "Summary" sheet:

Excel 2007

	A	B	C	D	E	F	G	H	I
1	Row Count:	15
2		Week	Total across all locations			Week to Import:	1	Day to Import:	Sun - Mon
3		1	92

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Summary​

Worksheet Formulas Cell Formula B1 =COUNTA(Data!A:A) C3 =SUM('2166:6634'!K4) <thead> </thead><tbody> </tbody>

<tbody>
</tbody>

The data sheet looks like:

Excel 2007

	A	B	C	D
1	Day	Location	Group	Number
2	Mon - Tue	2166	S	1
3	Mon - Tue	2166	S	2
4	Mon - Tue	2218		3
5	Mon - Tue	2218	S	4

<colgroup><col style="width: 25pxpx"><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Data​

This data, when transferred to the location sheet looks like:

Excel 2007

	A	B	C	D	E	F	G	H	I
3			Sun - Mon	Mon - Tue	Tue - Wed	Wed - Thu	Thu - Fri	Fri - Sat	Sat - Sun
4	Week	1	1
5			2
6
7

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

2166​

My code looks like:

Sub NumbersToLocations()


'if the location (column B in the Data sheet) matches the sheet name and there is an "S" in column 3 then
'copy the number (column D) and paste into the location sheet
'loop through all rows in Data sheet and all location sheets


Dim r As Integer    'r is the row number the data is being copied from
Dim rn As Integer   'rn is the row number to paste the first result - decided by the week number, cell G2 in the Summary sheet
Dim cn As Integer   'cn is the column number to paste the 1st result - decided by the day, cell I2 in the Summary sheet
Dim count As Integer    'count is counting the number of sheets in the workbook
Dim os As Integer   'os is the row number offset to use when pasting 2nd, 3rd and 4th results
Dim wsn As Integer  'wsn is the work sheet name to paste into
Dim boxes As Integer    'boxes is the number to paste
Dim lastrow As Integer  'lastrow is the number of rows to loop through, it is a counta sum in cell B1 in the Summary sheet


Worksheets("Summary").Activate


lastrow = Cells(1, 2)


'what week number is being run?
'which row does the data need pasting into?
If Cells(2, 7) = 1 Then
rn = 4
End If
If Cells(2, 7) = 2 Then
rn = 8
End If
If Cells(2, 7) = 3 Then
rn = 12
End If
If Cells(2, 7) = 4 Then
rn = 16
End If
If Cells(2, 7) = 5 Then
rn = 20
End If
If Cells(2, 7) = 6 Then
rn = 24
End If
If Cells(2, 7) = 7 Then
rn = 28
End If
If Cells(2, 7) = 8 Then
rn = 32
End If
If Cells(2, 7) = 9 Then
rn = 36
End If
If Cells(2, 7) = 10 Then
rn = 40
End If
If Cells(2, 7) = 11 Then
rn = 44
End If
If Cells(2, 7) = 12 Then
rn = 48
End If
If Cells(2, 7) = 13 Then
rn = 52
End If
If Cells(2, 7) = 14 Then
rn = 56
End If
If Cells(2, 7) = 15 Then
rn = 60
End If
If Cells(2, 7) = 16 Then
rn = 64
End If
If Cells(2, 7) = 17 Then
rn = 68
End If
If Cells(2, 7) = 18 Then
rn = 72
End If
If Cells(2, 7) = 19 Then
rn = 76
End If
If Cells(2, 7) = 20 Then
rn = 80
End If
If Cells(2, 7) = 21 Then
rn = 84
End If
If Cells(2, 7) = 22 Then
rn = 88
End If
If Cells(2, 7) = 23 Then
rn = 92
End If
If Cells(2, 7) = 24 Then
rn = 96
End If
If Cells(2, 7) = 25 Then
rn = 100
End If
If Cells(2, 7) = 26 Then
rn = 104
End If
If Cells(2, 7) = 27 Then
rn = 108
End If
If Cells(2, 7) = 28 Then
rn = 112
End If
If Cells(2, 7) = 29 Then
rn = 116
End If
If Cells(2, 7) = 30 Then
rn = 120
End If
If Cells(2, 7) = 31 Then
rn = 124
End If
If Cells(2, 7) = 32 Then
rn = 128
End If
If Cells(2, 7) = 33 Then
rn = 132
End If
If Cells(2, 7) = 34 Then
rn = 136
End If
If Cells(2, 7) = 35 Then
rn = 140
End If
If Cells(2, 7) = 36 Then
rn = 144
End If
If Cells(2, 7) = 37 Then
rn = 148
End If
If Cells(2, 7) = 38 Then
rn = 152
End If
If Cells(2, 7) = 39 Then
rn = 156
End If
If Cells(2, 7) = 40 Then
rn = 160
End If
If Cells(2, 7) = 41 Then
rn = 164
End If
If Cells(2, 7) = 42 Then
rn = 168
End If
If Cells(2, 7) = 43 Then
rn = 172
End If
If Cells(2, 7) = 44 Then
rn = 176
End If
If Cells(2, 7) = 45 Then
rn = 180
End If
If Cells(2, 7) = 46 Then
rn = 184
End If
If Cells(2, 7) = 47 Then
rn = 188
End If
If Cells(2, 7) = 48 Then
rn = 192
End If
If Cells(2, 7) = 49 Then
rn = 196
End If
If Cells(2, 7) = 50 Then
rn = 200
End If
If Cells(2, 7) = 51 Then
rn = 204
End If
If Cells(2, 7) = 52 Then
rn = 208
End If
If Cells(2, 7) = 53 Then
rn = 212
End If


'what report/day is being run?
'which column does the data need pasting into?
If Cells(2, 9) = "Sun - Mon" Then
cn = 3
End If
If Cells(2, 9) = "Mon - Tue" Then
cn = 4
End If
If Cells(2, 9) = "Tue - Wed" Then
cn = 5
End If
If Cells(2, 9) = "Wed - Thu" Then
cn = 6
End If
If Cells(2, 9) = "Thu - Fri" Then
cn = 7
End If
If Cells(2, 9) = "Fri - Sat" Then
cn = 8
End If
If Cells(2, 9) = "Sat - Sun" Then
cn = 9
End If


For ws = 3 To Worksheets.count
    Worksheets(ws).Activate
    wsn = ActiveSheet.Name
    
    os = 0
    Worksheets("Data").Activate


        For r = 2 To lastrow
            Worksheets("Data").Activate
        If Cells(r, 2) = wsn And Cells(r, 3) = "S" Then
                boxes = Cells(r, 4)




    Worksheets(ws).Activate


    Cells(rn + os, cn) = boxes
    os = os + 1
    End If
    Next r
    


Next ws


End Sub

All location sheets are set out the same with 4 rows per week but I would like to add a formula to the code so it looks up the week number in each of the sheets in case I have to add a row later in the year.

I hope I have explained what I'm looking for well enough.

 

[Snakehips]

northrops,

At first glance, you can replace al the If statements that determine rn with...

rn = Cells(2,7) * 4

Hope that helps.

 

[northrops]

Thanks, I was just about to post that same answer myself!
This relies on all the location sheets to have the same number of rows. I would like to be able to determine the rn by using a formula in case I need to extend the sheets.

 

[hiker95]

northrops,

Thanks for the Private Message.

In this instance it would help if we could see your workbook.

You can upload your workbook to Box Net,
sensitive data scrubbed/removed/changed
mark the workbook for sharing
and provide us with a link to your workbook.

 

[northrops]

Link to workbook:

https://www.box.com/s/7tww4ltxm74cgr8fz0np

 

[Snakehips]

northrop,

I have not looked at your uploaded file but perhaps this gives you the flexibility you need to increas your rows....

Sub NumbersToLocations()
'if the location (column B in the Data sheet) matches the sheet name and there is an "S" in column 3 then
'copy the number (column D) and paste into the location sheet
'loop through all rows in Data sheet and all location sheets

Dim r As Integer    'r is the row number the data is being copied from
Dim rn As Integer   'rn is the row number to paste the first result - decided by the week number, cell G2 in the Summary sheet
Dim cn As Integer   'cn is the column number to paste the 1st result - decided by the day, cell I2 in the Summary sheet
Dim count As Integer    'count is counting the number of sheets in the workbook
Dim os As Integer   'os is the row number offset to use when pasting 2nd, 3rd and 4th results
Dim wsn As Integer  'wsn is the work sheet name to paste into
Dim boxes As Integer    'boxes is the number to paste
Dim lastrow As Integer  'lastrow is the number of rows to loop through, it is a counta sum in cell B1 in the Summary sheet
Dim WkNum As Integer
With Worksheets("Summary")
'*******can do away with sheet cell holding lastrow
lastrow = Sheets("Data").Cells(Rows.count, 1).End(xlUp).Row
'what week number is being run?
WkNum = Sheets("Summary").Range("G2").Value
'what report/day is being run?
'which column does the data need pasting into?
If .Cells(2, 9) = "Sun - Mon" Then
cn = 3
End If
If .Cells(2, 9) = "Mon - Tue" Then
cn = 4
End If
If .Cells(2, 9) = "Tue - Wed" Then
cn = 5
End If
If .Cells(2, 9) = "Wed - Thu" Then
cn = 6
End If
If .Cells(2, 9) = "Thu - Fri" Then
cn = 7
End If
If .Cells(2, 9) = "Fri - Sat" Then
cn = 8
End If
If Cells(2, 9) = "Sat - Sun" Then
cn = 9
End If
End With
For ws = 3 To Worksheets.count
    wsn = Worksheets(ws).Name
    
    os = 0
        For r = 2 To lastrow
            
        If Worksheets("Data").Cells(r, 2) = wsn And Worksheets("Data").Cells(r, 3) = "S" Then
                boxes = Worksheets("Data").Cells(r, 4)
'which row does the data need pasting into?
rn = Application.Match(WkNum, Worksheets(ws).Range("B:B"), 0)
    Worksheets(ws).Cells(rn + os, cn) = boxes
    os = os + 1
    End If
    Next r
Next ws
End Sub

Note that I have avoided activating the various sheets, all of which adds to processing time.

Hope that helps.

 

[northrops]

Snakehips, that is exactly what I was after.
Thank you very much.

 

[hiker95]

northrops,

This relies on all the location sheets to have the same number of rows. I would like to be able to determine the rn by using a formula in case I need to extend the sheets.

I would think that you should determine, based on the requirements of the project, what the maximum number of rows that should be allocated for each week + a safe additional number of rows, for each week in all the worksheets, for at least 1 years worth of work.

If you do not do this, then you will have to have code to first check if the sheet you are copying to, for a particular week number, has room for the data being copied, and, if not, then add rows to that area.

 

[northrops]

There are only 1 or 2 entries per day per sheet at the moment but I have just added a warning message box that will alert me to add a row if there are more than 4 entries in any location.

Thanks again.