PLEASE HELP ! "SPLIT AMOUNT BY MACRO"

[K]

Hi,
In column "A" of "Sheet 1" I have codes like "A" , "B" , "C" which
indicates that how amount should be split into months of a year and in
column "B" of "Sheet 1" I have amount figures against the codes which
are in column "A".

A B -------columns
A 1000
B 2000
C 3000

In cells "A114" of "Sheet 2" I have percentage data table which
indicates that which code in coloumn "A" of "Sheet 1" should split
amount (which is in column "B" cells) into which way (please see the
data table below)

A B C D ----Columns
Month A B C ----Headings
200701 8 0 10---percentages
200702 8 0 10
200703 9 0 10
200704 8 0 10
200705 8 0 10
200706 9 14 10
200707 8 14 10
200708 8 15 10
200709 9 14 10
200710 8 14 10
200711 8 15 0
200712 9 14 0
Total 100 100 100

(please not that in column "A" of "Sheet 2" Month is coded as 200701
which mean that year 2007 and 01 first month)
I want macro which should be set on a button and it should cover the
Range ("A2:B10") of "Sheet 1" and it should put the results on "Sheet
3" leaving the first row as that will be use for Headings. Macro
should work as when I put any code from "A to C" in cell "A2 of column
"A" of "Sheet 1" and any amount in column "B" against the code then it
should split that amount the way its shown in "Sheet 2" percentage
data table and put the result in "Sheet 3" and when i put another code
in cell "A3" of column "A" in "Sheet 1" and any other amount in column
"B" then it should again split the amount and now it should put the
result in "Sheet 3" but below the fist result.
FOR EXAMPLE if I put data in "Sheet 1" from cell "A2 of column "A" as
shown below

A B -------columns
A 1000
B 2000
C 3000

Then Macro should produce result in "Sheet 3" as shown below

A B C ------Columns
Month Code Amt -----Headings
200701 A 80
200702 A 80
200703 A 90
200704 A 80
200705 A 80
200706 A 90
200707 A 80
200708 A 80
200709 A 90
200710 A 80
200711 A 80
200712 A 90
200701 B 0
200702 B 0
200703 B 0
200704 B 0
200705 B 0
200706 B 280
200707 B 280
200708 B 300
200709 B 280
200710 B 280
200711 B 300
200712 B 280
200701 C 300
200702 C 300
200703 C 300
200704 C 300
200705 C 300
200706 C 300
200707 C 300
200708 C 300
200709 C 300
200710 C 300
200711 C 0
200712 C 0

I'll be very greatful if anybody can help as this macro will make lots
of people jobs easy. Thanks

 

[Bernie Deitrick]

K,

Try the macro below. Select the cells on Sheet 1 with the amounts, then run the macro. This assumes
that the percentages on Sheet2 are actual percentages (for example, the 8 in your example is actuall
0.08 formatted to show 8%). Otherwise, you will need to divide those numbers by 100.

HTH,
Bernie
MS Excel MVP

Sub DistributeNow()
Dim myR As Range
Dim mySel As Range
Dim myC As Range
Dim myH As Range
Dim mySh As Worksheet
Dim i As Integer

Set mySel = Selection
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Sheet 3").Delete
Application.DisplayAlerts = True

Worksheets("Sheet 2").Copy Before:=Worksheets("Sheet2")
ActiveSheet.Name = "Sheet3"

Set myH = Worksheets("Sheet 3").Range("1:1")
For Each myC In mySel
Set myR = myH.Cells(1, Application.Match(myC(1, 0).Value, myH, False))
Set myR = Range(myR, myR.End(xlDown))
myC.Copy
myR.PasteSpecial xlPasteValues, xlPasteSpecialOperationMultiply
Next myC



Set myR = Range("A2", Cells(Rows.Count, 1).End(xlUp))
Columns("B:B").Insert Shift:=xlToRight
Set myH = Range("C1", Range("IV1").End(xlToLeft))

myR.Copy myR.Offset(myR.Rows.Count, 0).Resize(myR.Rows.Count * (myH.Cells.Count - 1), 1)
For i = 1 To myH.Cells.Count
myH.Cells(1, i).Copy
myR.Offset(myR.Rows.Count * (i - 1), 1).PasteSpecial Paste:=xlPasteValues
myH.Cells(1, i).Offset(1, 0).Resize(myR.Rows.Count, 1).Cut
myR.Offset(myR.Rows.Count * (i - 1), 2).Select
ActiveSheet.Paste
Next i
myH.Clear
Range("A1").Value = "Month"
Range("B1").Value = "Code"
Range("C1").Value = "Amount"
End Sub