Percent increase calculations...

**Spitfire999** · 06-15-2007, 09:03 AM

Anyone?

I would really appreciate it.

**NBVC** · 06-15-2007, 10:15 AM

Not exactly sure what which columns you mean by "current year" and "past year"

Try this code and see if it does what you want. You will see that after you hit the copy button, the 3rd column will be 0's, as you add figures in the Column E, the calculations will adjust.....is this right?

Option Explicit

'Code created and edited by NBVC and Ska67Can

Sub CopyPaste()

Dim sht As Worksheet
Dim LastRow As Long, LastCol As Long, LastRow2 As Long, LastCol2 As Long

For Each sht In ActiveWorkbook.Sheets
    If sht.Name <> "Instructions" And sht.Name <> "SATcosts" Then
       LastRow = sht.Cells(65536, 4).End(xlUp).Row
       LastCol = sht.Cells(5, 256).End(xlToLeft).Column
       ' Check if Year has changed.  If yes, proceed, else warning given.
       
       
           If sht.Cells(1, 2).Value <> Year(Now()) Then
           sht.Cells(4, LastCol + 1).Value = sht.Cells(1, 2).Value - 1
           Range(sht.Cells(5, 4), sht.Cells(LastRow, 5)).Copy
           sht.Cells(5, LastCol + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
               :=False, Transpose:=False
           
           
           'sht.Cells(5, LastCol + 1).Value = 0
    
           LastCol2 = sht.Cells(5, 256).End(xlToLeft).Column
           LastRow2 = sht.Cells(65536, LastCol2).End(xlUp).Row
           
           ' calculate percentage change
           With sht.Range(Cells(5, LastCol2 + 1).Address, Cells(LastRow2, LastCol2 + 1).Address)
                .Formula = "=(" & Range("E6").Address(rowabsolute:=False) & "-" & Range("P6").Address(rowabsolute:=False) & ")/" & Range("E6").Address(rowabsolute:=False)
           End With
    
           ' Add left/right borders
           With Range(sht.Cells(4, LastCol2 - 1), sht.Cells(LastRow2, LastCol2)).Borders(xlEdgeLeft)
               .LineStyle = xlContinuous
               .Weight = xlThin
               .ColorIndex = xlAutomatic
           End With
           With Range(sht.Cells(4, LastCol2 - 1), sht.Cells(LastRow2, LastCol2)).Borders(xlEdgeRight)
               .LineStyle = xlContinuous
               .Weight = xlThin
               .ColorIndex = xlAutomatic
           End With
           Application.CutCopyMode = False ' Clear clipboard so big clipboard dialog will not appear when closing main workbook
        Else
            MsgBox "Year has not changed!"
            Exit For
        End If
    End If
Next sht

End Sub

BTW: My handle is NBVC.....not MBVC...

**Spitfire999** · 06-15-2007, 11:01 AM

Sort of on the right lines, I have just attached a single spread sheet to demonstrate what the desired output should look like. When I add the current year to the history table, by running the macro, I want it to insert a column like the ones i highlighted in blue.

Hopefully that makes a bit more sense. And really sorry about the handle mishap...its all peachy now.

**NBVC** · 06-15-2007, 11:57 AM

Try this code:

Option Explicit

'Code created and edited by NBVC and Ska67Can

Sub CopyPaste()

Dim sht As Worksheet
Dim LastRow As Long, LastCol As Long, LastRow2 As Long, LastCol2 As Long

For Each sht In ActiveWorkbook.Sheets
    If sht.Name <> "Instructions" And sht.Name <> "SATcosts" Then
       LastRow = sht.Cells(65536, 4).End(xlUp).Row
       LastCol = sht.Cells(5, 256).End(xlToLeft).Column
       ' Check if Year has changed.  If yes, proceed, else warning given.
       
       
           If sht.Cells(1, 2).Value <> Year(Now()) Then
           sht.Cells(4, LastCol + 1).Value = sht.Cells(1, 2).Value - 1
           Range(sht.Cells(5, 4), sht.Cells(LastRow, 5)).Copy
           sht.Cells(5, LastCol + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
               :=False, Transpose:=False
           
           
           'sht.Cells(5, LastCol + 1).Value = 0
    
           LastCol2 = sht.Cells(5, 256).End(xlToLeft).Column
           LastRow2 = sht.Cells(65536, LastCol2).End(xlUp).Row
           
           ' calculate percentage change
           With sht.Range(Cells(5, LastCol2 + 1).Address, Cells(LastRow2, LastCol2 + 1).Address)
                .Formula = "=(" & Cells(6, LastCol2).Address(rowabsolute:=False) & "-" & Cells(6, LastCol2 - 2).Address(rowabsolute:=False) & ")/" & Cells(6, LastCol2).Address(rowabsolute:=False)
           End With
           
           With Range(Cells(5, LastCol2 + 1), Cells(LastRow2, LastCol2 + 1))
                .Font.ColorIndex = 41
            End With
    
           ' Add left/right borders
           With Range(sht.Cells(4, LastCol2 - 1), sht.Cells(LastRow2, LastCol2)).Borders(xlEdgeLeft)
               .LineStyle = xlContinuous
               .Weight = xlThin
               .ColorIndex = xlAutomatic
           End With
           With Range(sht.Cells(4, LastCol2 + 1), sht.Cells(LastRow2, LastCol2)).Borders(xlEdgeRight)
               .LineStyle = xlContinuous
               .Weight = xlThin
               .ColorIndex = xlAutomatic
           End With
           With Range(sht.Cells(4, LastCol2 - 1), sht.Cells(4, LastCol2 + 1)).Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
           End With
            With Range(sht.Cells(4, LastCol2 - 1), sht.Cells(4, LastCol2 + 1)).Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
            End With
            Application.CutCopyMode = False ' Clear clipboard so big clipboard dialog will not appear when closing main workbook
          
        Else
            MsgBox "Year has not changed!"
            Exit For
        End If
    End If
Next sht

End Sub

**Spitfire999** · 06-15-2007, 01:33 PM

Wow, again worked just great...
Hopefully after this my project will be about 99% done which will make me very happy.

But just wondering, as just touch up, would you happen to know what I should put in so that

a. when the numbers are copied and pasted from the current table, that the price is formated in currency form (U.S $ with 2 decimal places)?

b. that the % increase cells are formatted in percent form.

and...

c. How if there is no value for the previous year that when calculating the increase % that it simply leaves the cell blank? (or vice versa where there is no current year price for it).

oh, and NBVC, I owe you something for all your trouble, I just have to think of what...

**NBVC** · 06-15-2007, 02:12 PM

Try this:

Option Explicit

'Code created and edited by NBVC and Ska67Can

Sub CopyPaste()

Dim sht As Worksheet
Dim LastRow As Long, LastCol As Long, LastRow2 As Long, LastCol2 As Long

For Each sht In ActiveWorkbook.Sheets
    If sht.Name <> "Instructions" And sht.Name <> "SATcosts" Then
       LastRow = sht.Cells(65536, 4).End(xlUp).Row
       LastCol = sht.Cells(5, 256).End(xlToLeft).Column
       ' Check if Year has changed.  If yes, proceed, else warning given.
       
       
           If sht.Cells(1, 2).Value <> Year(Now()) Then
           sht.Cells(4, LastCol + 1).Value = sht.Cells(1, 2).Value - 1
           Range(sht.Cells(5, 4), sht.Cells(LastRow, 5)).Copy
           sht.Cells(5, LastCol + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
               :=False, Transpose:=False
           
           
           'sht.Cells(5, LastCol + 1).Value = 0
    
           LastCol2 = sht.Cells(5, 256).End(xlToLeft).Column
           LastRow2 = sht.Cells(65536, LastCol2).End(xlUp).Row
           
           ' calculate percentage change
           With sht.Range(Cells(5, LastCol2 + 1).Address, Cells(LastRow2, LastCol2 + 1).Address)
                .Formula = "=IF(OR(" & Cells(5, LastCol2).Address(rowabsolute:=False) & "=""""," & Cells(5, LastCol2 - 2).Address(rowabsolute:=False) & "=""""),"""",(" & Cells(5, LastCol2).Address(rowabsolute:=False) & "-" & Cells(5, LastCol2 - 2).Address(rowabsolute:=False) & ")/" & Cells(5, LastCol2).Address(rowabsolute:=False) & ")"
                .Font.ColorIndex = 41
                .Style = "Percent"
           End With
           
           With Range(sht.Cells(4, LastCol2), sht.Cells(LastRow2, LastCol2))
                .Style = "Currency"
           End With
           
           ' Add left/right borders
           With Range(sht.Cells(4, LastCol2 - 1), sht.Cells(LastRow2, LastCol2)).Borders(xlEdgeLeft)
               .LineStyle = xlContinuous
               .Weight = xlThin
               .ColorIndex = xlAutomatic
           End With
           With Range(sht.Cells(4, LastCol2 + 1), sht.Cells(LastRow2, LastCol2)).Borders(xlEdgeRight)
               .LineStyle = xlContinuous
               .Weight = xlThin
               .ColorIndex = xlAutomatic
           End With
           With Range(sht.Cells(4, LastCol2 - 1), sht.Cells(4, LastCol2 + 1)).Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
           End With
            With Range(sht.Cells(4, LastCol2 - 1), sht.Cells(4, LastCol2 + 1)).Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
            End With
            Application.CutCopyMode = False ' Clear clipboard so big clipboard dialog will not appear when closing main workbook
          
        Else
            MsgBox "Year has not changed!"
            Exit For
        End If
    End If
Next sht

End Sub

**Spitfire999** · 06-15-2007, 02:28 PM

again, wow, simply great...

I think this about finishes up this workbook, But I'm sure ill stick around and ill prolly be having some more questions in the not to distant future.

But again thank you so much to NBVC and to Ska. I really appreciate all the help that you guys gave me, and you make this forum an absolute pleasure to come to for help.

-Ben-

Percent increase calculations...

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions