# Divide Monthly Quantity into Weekly Quantity...

#### jitendra.mistry

##### New Member
Hello,

I am new into Macros world and I'm stuck with a problem:

What I managed to do by my self:
- Convert horizontal Monthly plan (Sheet1) into Vertical Monthly Plan (Sheet2) (plz see the attached file)

What I would like to:
- Convert this Vertical Monthly Plan into Veritcal Weekly Plan (Sheet3)

eg:
if plan is XYZ1 (Product) : 150 qty (Monthly production) Starting from 01/07/2010
XYZ2 (Product) : 150 qty (Monthly production) Starting from 01/08/2010

so after weekly macro run I should get something like in Sheet3 in respective column A:B:C (Horizontally)..

XYZ1 : 30 : 01/07/2010
XYZ1 : 30 : 08/07/2010
XYZ1 : 30 : 15/07/2010
XYZ1 : 30 : 22/07/2010
XYZ1 : 30 : 29/07/2010

Then XYZ2 should start by again at 01/08/2010...

XYZ2 : 30 : 01/08/2010
XYZ2 : 30 : 08/08/2010
XYZ2 : 30 : 15/08/2010
XYZ2 : 30 : 22/08/2010
XYZ2 : 30 : 29/08/2010

Macros Must consider the number of days in respective months

Also if possible please guide me to print this "Sheet3" only in Format *.CSV

Thanks alot guys
Cheers,
jitu

My Macros:

Public Sub TransformData()
Sheets("Sheet2").Select
Range("A1").CurrentRegion.Clear
Range("A1").Value = "Reference"
' Sheets("Sheet1").Select
' Range("A2:B35").Copy Destination:=Sheets("Sheet2").Range("A2")
Sheets("Sheet2").Select
Range("B1").Value = "Month"
Range("C1").Value = "Qty"
Sheets("Sheet1").Select
FinalRow = Range("A16000").End(xlUp).Row
NextRow = 2
LastRow = FinalRow
' Loop through the data columns
For i = 2 To 13
ThisCol = Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", i, 1)
' Copy the left columns from sheet1 to sheet2
Range("A2:C" & FinalRow).Copy Destination:= _
Sheets("Sheet2").Range("A" & NextRow)
' Copy the header from ThisCol to column C
Range(ThisCol & "1").Copy Destination:= _
Sheets("Sheet2").Range("B" & NextRow & ":C" & LastRow)
' Copy the data for this quarter to column D
Range(ThisCol & "2:" & ThisCol & FinalRow).Copy _
Destination:=Sheets("Sheet2").Range("B" & NextRow)
NextRow = LastRow + 1
LastRow = NextRow + FinalRow - 2
Next i
Sheets("Sheet2").Select
With Application

.Calculation = xlCalculationManual

.ScreenUpdating = False

'We work backwards because we are deleting rows.

LastRow = Range("B" & Rows.Count).End(xlUp).Row
For j = LastRow + 2 To 1 Step -1
If Cells(j, "B").Value = 0 Or Cells(j, "C").Value = "" Then
Cells(j, "C").EntireRow.Delete
End If
Next j

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

End Sub

### Excel Facts

Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

Replies
2
Views
127
Replies
0
Views
45
Replies
2
Views
276
Replies
1
Views
91
Replies
15
Views
142

1,211,434
Messages
6,101,831
Members
447,758
Latest member

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