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-questions/723804-visual-basic-applications-separate-monthly-data-into-weekly-data.html
http://www.excelforum.com/excel-programming-vba-macros/951715-vba-separate-monthly-data-into-weekly-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 (http://www.vbaexpress.com/forum/faq.php), 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.