VBA Separate monthly data into weekly data

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.

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

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

Code:

---

Set MainSht = ActiveSheet

---

Count the used rows

Code:

---

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

---

Step Thru the rows 7 at a time

Code:

---

For i = 1 to RowCount Step 7

---

Get a Name for the weekly Sheet

Code:

---

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

---

Add a new sheet to the end and name it

Code:

---

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

Code:

---

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

---

Loop

Code:

---

Next i

---

Will do.

Million thanks.

Trying it before going to sleep...

Solved on other forum:

Code:

---

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

---

Thanks for the feedback.