VBA Separate monthly data into weekly data

[Vokas]

Hello,

I'm thinking about this all day long and didn't come to conclusion how can i solve it. Hope you can help me with this.

What i need is a macro to separate (copy) montly data from one sheet into weekly data, creating new sheets for every week.

For example, I have a file with data from 02.05.2013 to 27.05.2013. I need macro to copy whole raws from 27.05.2013 till 21.05.2013. to another (new) sheet (called Week1) and so on (from 20.05. to 14.05 to Week2 sheet, etc...) taking in account cell A1 as starting date.

The dates i have in "montly" sheet (i call it monthly but it can contain data for 2-3 months) are in column A (descending order, containing only dates), and macro must take the first cell as a reference cell. (e.g. if A1 is 12.08.2013, it will start to separate data from that date). The last week will usually not be full week or it can contain only 1 day but that's ok.

Hope i explained it well.

Any thoughts? Maybe i'm missing somthing easy here.

Thanks in advance.

[rollis13]

Cross-Posts:
http://www.mrexcel.com/forum/excel-q...ekly-data.html
http://www.excelforum.com/excel-prog...ekly-data.html

[SamT]

Vokas,

Welcome to VBAExpress. You are forgiven this time because it is not in the Forum Rules page. Please read our FAQ, give a big Thank You to Rollis, and, post any solution type responses from other forums into your posts here. When you do solve the issue, please post it in all forum's and mark all threads as solved.

One code algorithm that should work is:

Keep the Main Sheet available

Set MainSht = ActiveSheet

Count the used rows

RowCount = Cells(Rows.Count, "A").End(xlUp).Row

Step Thru the rows 7 at a time

For i = 1 to RowCount Step 7

Get a Name for the weekly Sheet

NewSht = MainSht.Range("A" & i).Text

Add a new sheet to the end and name it

WorkSheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = NewSht

Using the cell we got NewSht from, Resize and copy it then paste it into NewSht

MainSht.Range("A" & i).Resize(7, 1).EntireRow.Copy Sheets(NewSht).Cells(1)

Loop

Next i

[Vokas]

Will do.

Million thanks.

Trying it before going to sleep...

[Vokas]

Solved on other forum:

Sub WeekOut()
 Dim n As Integer, wm As Worksheet, ww As Worksheet
Dim w As Long, r As Long, i As Long, D As Range, Ref As Integer

Set wm = ActiveSheet
 r = wm.Range("A" & Rows.Count).End(xlUp).row
 i = r

DefBlock:
 If r = 0 Then Exit Sub
Ref = Day(wm.Range("A" & r))

Do Until Day(CDate(wm.Range("A" & i - 1))) = Ref + 7
 i = i - 1
If i = 1 Then Exit Do
 Loop

 n = n + 1
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Week " & n

Set ww = ActiveSheet
 wm.Range("A" & i & ":A" & r).EntireRow.Copy ww.Range("A1")
r = i - 1
 i = r: GoTo DefBlock 

End Sub

[rollis13]

Thanks for the feedback.