Percent increase calculations...

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

**NBVC** · 06-15-2007, 03:03 PM

You're quite welcome.

I am glad that we came through for you.

**ska67can** · 06-15-2007, 03:14 PM

You're welcome, and sorry I wasn't able to get back to you sooner.

ska

**NBVC** · 06-15-2007, 03:57 PM

Spitfire999,

I just cleaned up the code a bit....to make it prettier...I like to make it look flowing....still functions the same.

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
           ' copy year over
           sht.Cells(4, LastCol + 1).Value = sht.Cells(1, 2).Value - 1
           ' copy date over
           Range(sht.Cells(5, 4), sht.Cells(LastRow, 5)).Copy
           sht.Cells(5, LastCol + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
               :=False, Transpose:=False
           ' determine last column and last row where data is pasted for formatting purposes
           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

Percent increase calculations...

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions