MACRO TO MULTIPLY AMOUNTS WITH PERCENTAGES

[K]

Hi all, Please see the link below where i have uploded my Sheet.

http://www.savefile.com/files/1535694

I uploded my file as i don' t think i can explain my question here. i
have put my question in above uploaded excel file clearly. Please can
any body help as it is very important for my project which i am doing
for my job. If any friend can help it will much appricated.

 

[Joel]

I get the same results you do. Nothing need to be done except run macro.
Macro creates new worksheet "results". If macro is run a 2nd time instead of
creating new worksheet it clears the present "results" worksheet.


Sub calc_results()

'check if worksheet results exists
Found = False
For Each sht In Sheets
If sht.Name = "Results" Then
Found = True
Exit For
End If
Next sht
If Found = True Then
'clear worksheet
Sheets("Results").Cells.Clear
Else
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Results"
End If
'copy head row from form to Results
With Sheets("Form")
.Rows(1).Copy Destination:=Sheets("Results").Rows(1)
Sheets("Results").Range("G1") = "PERIOD"
FormRowCount = 2
ResultsRowCount = 2
Do While .Range("A" & FormRowCount) <> ""
For MyMonth = 1 To 12
.Rows(FormRowCount).Copy _
Destination:=Sheets("Results").Rows(ResultsRowCount)
Period = Val(Format(Date, "YYYY") & Format(MyMonth, "0#"))
Code = .Range("D" & FormRowCount)
With Sheets("PERCENTAGES DATA")
Set PercentRow = .Columns("A").Find(what:=Code, _
LookIn:=xlValues, lookat:=xlWhole)
If PercentRow Is Nothing Then
MsgBox ("Cannot find Code : " & Code)
Exit Sub
End If
Set PercentCol = .Rows(2).Find(what:=Period, _
LookIn:=xlValues, lookat:=xlWhole)
If PercentCol Is Nothing Then
MsgBox ("Cannot find Period : " & Period)
Exit Sub
End If
PercentNumber = .Cells(PercentRow.Row, PercentCol.Column) / 100
End With
With Sheets("Results")
.Range("G" & ResultsRowCount) = Period
.Range("E" & ResultsRowCount).Formula = _
"=" & PercentNumber & "*Form!E" & FormRowCount
End With
ResultsRowCount = ResultsRowCount + 1
Next MyMonth
FormRowCount = FormRowCount + 1
Loop
End With
Sheets("Results").Columns("A:G").Columns.AutoFit
End Sub

 

[K]

I get the same results you do.  Nothing need to be done except run macro..  
Macro creates new worksheet "results".  If macro is run a 2nd time instead of
creating new worksheet it clears the present "results" worksheet.

Sub calc_results()

'check if worksheet results exists
Found = False
For Each sht In Sheets
   If sht.Name = "Results" Then
      Found = True
      Exit For
   End If
Next sht
If Found = True Then
   'clear worksheet
   Sheets("Results").Cells.Clear
Else
   Sheets.Add after:=Sheets(Sheets.Count)
   ActiveSheet.Name = "Results"
End If
'copy head row from form to Results
With Sheets("Form")
   .Rows(1).Copy Destination:=Sheets("Results").Rows(1)
   Sheets("Results").Range("G1") = "PERIOD"
   FormRowCount = 2
   ResultsRowCount = 2
   Do While .Range("A" & FormRowCount) <> ""
      For MyMonth = 1 To 12
         .Rows(FormRowCount).Copy _
            Destination:=Sheets("Results").Rows(ResultsRowCount)
         Period = Val(Format(Date, "YYYY") & Format(MyMonth, "0#"))
         Code = .Range("D" & FormRowCount)
         With Sheets("PERCENTAGES DATA")
            Set PercentRow = .Columns("A").Find(what:=Code, _
               LookIn:=xlValues, lookat:=xlWhole)
            If PercentRow Is Nothing Then
               MsgBox ("Cannot find Code : " & Code)
               Exit Sub
            End If
            Set PercentCol = .Rows(2).Find(what:=Period, _
               LookIn:=xlValues, lookat:=xlWhole)
            If PercentCol Is Nothing Then
               MsgBox ("Cannot find Period : " & Period)
               Exit Sub
            End If
            PercentNumber = .Cells(PercentRow.Row, PercentCol.Column) / 100
         End With
         With Sheets("Results")
            .Range("G" & ResultsRowCount) = Period
            .Range("E" & ResultsRowCount).Formula = _
               "=" & PercentNumber & "*Form!E" & FormRowCount
         End With
         ResultsRowCount = ResultsRowCount + 1
      Next MyMonth
      FormRowCount = FormRowCount + 1
   Loop
End With
Sheets("Results").Columns("A:G").Columns.AutoFit
End Sub





- Show quoted text -

Thanks Joel your macro is working superb. Just little request that if
you can explain your macro that who its working so i can have better
understaning with your macro. thanks

 

[Joel]

I added more comments to the code. I also made some minor chages to make the
code a little bit more efficient.

Sub calc_results()

'check if worksheet results exists
Found = False
'Look in every sheet to see if the sheet "Results" exists
For Each sht In Sheets
If sht.Name = "Results" Then
Found = True
Exit For
End If
Next sht

If Found = True Then
'clear worksheet
Sheets("Results").Cells.Clear
Else
'Add new worsheet and name it "Results
'put new sheet as last sheet in workbook
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = "Results"
End If

'read data from Sheet "Form"
With Sheets("Form")

'copy header row from "Form" to "Results"
.Rows(1).Copy Destination:=Sheets("Results").Rows(1)
'Add Word Period to column G in first row
Sheets("Results").Range("G1") = "PERIOD"

'Start Looking for data on Form in row 2, skip header
FormRowCount = 2
'Put data in Results sheet in Row 2 after Header
ResultsRowCount = 2

'Loop through every row of the form
Do While .Range("A" & FormRowCount) <> ""

'get the code from the form worksheet in column D
Code = .Range("D" & FormRowCount)

'Write results for 12 months on Results Sheet
For MyMonth = 1 To 12
'The FOR loop will
'Copy one Row of data from "Form" sheet to "Results" Sheet
'The same row will be copied 12 times to 12 different rows in
Results
.Rows(FormRowCount).Copy _
Destination:=Sheets("Results").Rows(ResultsRowCount)

'Create the period using the current Year and a 2 digit month
'Period is a Number, not a string
'MyMonth is formated to create a two digit number
'Val will convert the two string to a single number
Period = Val(Format(Date, "YYYY") & Format(MyMonth, "0#"))

With Sheets("PERCENTAGES DATA")

'search for the code in Column A of the Percentage Data sheet
Set PercentRow = .Columns("A").Find(what:=Code, _
LookIn:=xlValues, lookat:=xlWhole)

'Display Error message if code is not found
If PercentRow Is Nothing Then
MsgBox ("Cannot find Code : " & Code)
Exit Sub
End If

'search for Period in Row 2 of the Percentage Data sheet
Set PercentCol = .Rows(2).Find(what:=Period, _
LookIn:=xlValues, lookat:=xlWhole)

'display error message if Period is not found
If PercentCol Is Nothing Then
MsgBox ("Cannot find Period : " & Period)
Exit Sub
End If

'get Percentage Number from the Percentage Data sheet
'convert percentage to fraction by dividing by 100
PercentNumber = .Cells(PercentRow.Row, PercentCol.Column) / 100
End With

With Sheets("Results")
'Write the Period in Column G in the Results sheet
.Range("G" & ResultsRowCount) = Period

'Add a formula to column E of the Results sheet that multiplies
'the Percentage number with the Amount in Form sheet
.Range("E" & ResultsRowCount).Formula = _
"=" & PercentNumber & "*Form!E" & FormRowCount
End With

'Increment the results row for each of the 12 months
ResultsRowCount = ResultsRowCount + 1
Next MyMonth

'get the Next Row of data from the Form sheet
FormRowCount = FormRowCount + 1
Loop
End With

'format the Results sheet
'Autofit all the columns
Sheets("Results").Columns("A:G").Columns.AutoFit
End Sub

 

[K]

I added more comments to the code.  I also made some minor chages to make the
code a little bit more efficient.

Sub calc_results()

'check if worksheet results exists
Found = False
'Look in every sheet to see if the sheet "Results" exists
For Each sht In Sheets
   If sht.Name = "Results" Then
      Found = True
      Exit For
   End If
Next sht

If Found = True Then
   'clear worksheet
   Sheets("Results").Cells.Clear
Else
   'Add new worsheet and name it "Results
   'put new sheet as last sheet in workbook
   Sheets.Add after:=Sheets(Sheets.Count)
   ActiveSheet.Name = "Results"
End If

'read data from Sheet "Form"
With Sheets("Form")

   'copy header row from "Form" to "Results"
   .Rows(1).Copy Destination:=Sheets("Results").Rows(1)
   'Add Word Period to column G in first row
   Sheets("Results").Range("G1") = "PERIOD"

   'Start Looking for data on Form in row 2, skip header
   FormRowCount = 2
   'Put data in Results sheet in Row 2 after Header
   ResultsRowCount = 2

   'Loop through every row of the form
   Do While .Range("A" & FormRowCount) <> ""

      'get the code from the form worksheet in column D
      Code = .Range("D" & FormRowCount)

      'Write results for 12 months on Results Sheet
      For MyMonth = 1 To 12
         'The FOR loop will
            'Copy one Row of data from "Form" sheet to "Results" Sheet
            'The same row will be copied 12 times to 12 different rows in
Results
         .Rows(FormRowCount).Copy _
            Destination:=Sheets("Results").Rows(ResultsRowCount)

         'Create the period using the current Year and a 2 digitmonth
         'Period is a Number, not a string
         'MyMonth is formated to create a two digit number
         'Val will convert the two string to a single number
         Period = Val(Format(Date, "YYYY") & Format(MyMonth, "0#"))

         With Sheets("PERCENTAGES DATA")

            'search for the code in Column A of the PercentageData sheet
            Set PercentRow = .Columns("A").Find(what:=Code, _
               LookIn:=xlValues, lookat:=xlWhole)

            'Display Error message if code is not found
            If PercentRow Is Nothing Then
               MsgBox ("Cannot find Code : " & Code)
               Exit Sub
            End If

            'search for Period in Row 2 of the Percentage Datasheet
            Set PercentCol = .Rows(2).Find(what:=Period, _
               LookIn:=xlValues, lookat:=xlWhole)

            'display error message if Period is not found
            If PercentCol Is Nothing Then
               MsgBox ("Cannot find Period : " & Period)
               Exit Sub
            End If

            'get Percentage Number from the Percentage Data sheet
            'convert percentage to fraction by dividing by 100
            PercentNumber = .Cells(PercentRow.Row, PercentCol.Column) / 100
         End With

         With Sheets("Results")
            'Write the Period in Column G in the Results sheet
            .Range("G" & ResultsRowCount) = Period

            'Add a formula to column E of the Results sheet that multiplies
            'the Percentage number with the Amount in Form sheet
            .Range("E" & ResultsRowCount).Formula = _
               "=" & PercentNumber & "*Form!E" & FormRowCount
         End With

         'Increment the results row for each of the 12 months
         ResultsRowCount = ResultsRowCount + 1
      Next MyMonth

      'get the Next Row of data from the Form sheet
      FormRowCount = FormRowCount + 1
   Loop
End With

'format the Results sheet
'Autofit all the columns
Sheets("Results").Columns("A:G").Columns.AutoFit
End Sub






- Show quoted text -

Thanks lot Joel it explain a lot. I am using your code and its
working superb. just another question i have another code whcih does
the smilar job like the macro you gave me but it not gives the msgbox
to tell which code or period is not found. Can you please help me in
this that what and where i put the code line in macro below so it also
give message box that if any code or period not found and then Exit
Sub. Please see the macro below (you can put this code in the sheet
so you can better understand the function - http://www.savefile.com/files/1535694
)

Sub MultAmt()
Const x = 12
Dim i As Integer
Dim LRow As Long
Dim rng As Range, c As Range
Dim rng2 As Range, c2 As Range

LRow = Sheets("FORM").Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets("FORM").Range("D2" & LRow)
LRow = Sheets("RESULT BY MACRO").Cells(Rows.Count, "A").End(xlUp).Row
If LRow = 1 Then
'do nothing
Else
Sheets("RESULT BY MACRO").Rows("2:" & LRow).Delete
End If
i = 1
For Each c In rng
LRow = Sheets("RESULT BY MACRO").Cells(Rows.Count,
"A").End(xlUp).Row
c.EntireRow.Copy Sheets("RESULT BY MACRO").Range("A" & LRow +
i & ":A" & LRow + x)
Next
LRow = Sheets("RESULT BY MACRO").Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets("RESULT BY MACRO").Range("D2" & LRow)
LRow = Sheets("PERCENTAGES DATA").Cells(Rows.Count, "A").End(xlUp).Row
Set rng2 = Sheets("PERCENTAGES DATA").Range("A3:M" & LRow)
i = 2
For Each c In rng
c.Offset(, 1).Value = c.Offset(, 1).Value * _
(Application.WorksheetFunction.VLookup(c.Value, rng2, i,
False) / 100)
c.Offset(, 3).Value = Sheet1.Cells(2, i).Value
If i = 13 Then
i = 2
Else
i = i + 1
End If
Next
End Sub

 

[Joel]

If yoiu are so concerned about properly documenting your code you should also
use variables that have MEANING. What are c1 and c2 used for??? compare my
code with your code and look at which code is easier to understand. Well
writeen code has the following
1) Plenty of whitespaces to make it easy to read
2) break complex statements into multiple statements.
3) Use variables theat have meaning.

I had two teaches in college who taught programming. They were
Son-of-a-Bitch. the same BITCH. They were actually brothers. One taught
PASCAL and Fortran and graded based on the amount of comments you had in your
code. the second taught assembly language. He was tougher. He took point
off for too little comments and too much comments. It had to be just right.
He also took off point if you had to many lines of code or too little (if
using tricks to reduce lines made the code confusing). I only got B's in his
course because I used 12 lines of code where he did it in 11 lines.

Sub MultAmt()
Const x = 12
Dim i As Integer
Dim LRow As Long
Dim rng As Range, search_code As Range
Dim rng2 As Range, c2 As Range

LRow = Sheets("FORM").Cells(Rows.Count, "A").End(xlUp).Row
Set codes = Sheets("FORM").Range("D2" & LRow)
LRow = Sheets("RESULT BY MACRO").Cells(Rows.Count, "A").End(xlUp).Row
If LRow = 1 Then
'do nothing
Else
Sheets("RESULT BY MACRO").Rows("2:" & LRow).Delete
End If
i = 1
For Each search_code In codes
LRow = Sheets("RESULT BY MACRO").Cells(Rows.Count,
"A").End(xlUp).Row
search_code.EntireRow.Copy Sheets("RESULT BY MACRO").Range("A" &
LRow +
i & ":A" & LRow + x)
Next
LRow = Sheets("RESULT BY MACRO").Cells(Rows.Count, "A").End(xlUp).Row

Set rng = Sheets("RESULT BY MACRO").Range("D2" & LRow)
LRow = Sheets("PERCENTAGES DATA").Cells(Rows.Count, "A").End(xlUp).Row

'change range to column A only
Set code_range = Sheets("PERCENTAGES DATA").Range("A3:A" & LRow)
i = 2
For Each c In rng
set mode_cell = code_range.find(what:=c.value, _
lookin:=xlvalues,lookat:=xlwhole)
if mode_cell is nothing then
msgbox("Cannot find Code : " & c.value)
exit sub
else
Percentage = mode_cell.offset(0,1)/100
end if

c.Offset(, 1).Value = c.Offset(, 1).Value * Percentage
c.Offset(, 3).Value = Sheet1.Cells(2, i).Value
If i = 13 Then
i = 2
Else
i = i + 1
End If
Next
End Sub