We help IT Professionals succeed at work.

Check out our new AWS podcast with Certified Expert, Phil Phillips! Listen to "How to Execute a Seamless AWS Migration" on EE or on your favorite podcast platform. Listen Now

x

Excel Macro

taverny
taverny asked
on
Medium Priority
289 Views
Last Modified: 2012-05-11
Hi Experts,
I currently have a macro made in Excel to add a new column to my data and calculate the networkingdays.
I would like to modify the code or add a new code , that will calculate the median  and the mode at the bottom of the Net work Days column , for each one of my sheet.
then to have a new sheet created at the end with the result for each sheet .
so basically it will have
ILSHOPQTETIME: Median
                             Mode
MISHOPQTETIME: Median
                             Mode

Here is the original question with the macro created for me .
https://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_26971985.html


Thanks in Advance.
David
Comment
Watch Question

Like This?

Sample File Attached.

Sid

Code Used

Option Explicit

'~~> Change the path of the file here
Const FilePath As String = "C:\Rawdata.xls"

Const HeaderText1a As String = "RECEIVE DATE"
Const HeaderText1b As String = "DATE RECEIVED"
Const HeaderText1c As String = "QUOTE DATE"

Const HeaderText2a As String = "APPROVED DATE"
Const HeaderText2b As String = "INVOICE DATE"

Const headerText As String = "NET WORK DAYS"

'~~> Three Combinations used to calculate Networking days
'RECEIVE DATE    Quote Date
'APPROVED DATE   INVOICE DATE
'DATE RECEIVED   QUOTE DATE

Private Sub CommandButton1_Click()
    Dim wb1 As Workbook
    Dim ws As Worksheet
    Dim LastRowWs As Long, c1 As Long, i As Long
    Dim Rng1 As Range, Rng2 As Range
    Dim Head1a As Boolean, Head1b As Boolean, Head1c As Boolean
    Dim Head2a As Boolean, Head2b As Boolean
    
    Set wb1 = Workbooks.Open(FilePath)
    
    For Each ws In wb1.Worksheets
        With ws
            Head1a = False: Head1b = False: Head1c = False
            Head2a = False: Head2b = False
            LastRowWs = .Range("A" & .Rows.Count).End(xlUp).Row
            c1 = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            .Cells(1, c1) = headerText
            
            '~~> Check for HeaderText1a
            For i = 1 To c1 - 1
                If InStr(1, .Cells(1, i).Value, HeaderText1a, vbTextCompare) Then
                    Head1a = True
                    Set Rng1 = .Cells(1, i)
                    Exit For
                End If
            Next i
            
            '~~> Check for HeaderText1b
            For i = 1 To c1 - 1
                If InStr(1, .Cells(1, i).Value, HeaderText1b, vbTextCompare) Then
                    Head1b = True
                    Set Rng1 = .Cells(1, i)
                    Exit For
                End If
            Next i
            
            '~~> Check for HeaderText1c
            If Head1a = True Or Head1b = True Then
                For i = 1 To c1 - 1
                    If InStr(1, .Cells(1, i).Value, HeaderText1c, vbTextCompare) Then
                        Head1c = True
                        Set Rng2 = .Cells(1, i)
                        Exit For
                    End If
                Next i
            End If
            
            '~~> Check for HeaderText2a if the above is not found
            If Head1c = False Then
                For i = 1 To c1 - 1
                    If InStr(1, .Cells(1, i).Value, HeaderText2a, vbTextCompare) Then
                        Head2a = True
                        Set Rng1 = .Cells(1, i)
                        Exit For
                    End If
                 Next i
            End If
            
            '~~> Check for HeaderText2b
            If Head2a = True Then
                For i = 1 To c1 - 1
                    If InStr(1, .Cells(1, i).Value, HeaderText2b, vbTextCompare) Then
                        Head2a = True
                        Set Rng2 = .Cells(1, i)
                        Exit For
                    End If
                Next i
            End If
            
            .Cells(2, c1).Formula = "=ABS(NETWORKDAYS(" & Replace(Rng1.Offset(1).Address, "$", "") & _
                                    "," & _
                                    Replace(Rng2.Offset(1).Address, "$", "") & _
                                    "))"
            
            On Error Resume Next
            .Cells(2, c1).AutoFill Destination:=.Range(.Cells(2, c1).Address & ":" & .Cells(LastRowWs, c1).Address), Type:=xlFillDefault
            On Error GoTo 0
            .Cells(LastRowWs + 1, c1 - 1) = "MEDIAN"
            .Cells(LastRowWs + 1, c1).Formula = "=Median(" & .Cells(2, c1).Address & ":" & .Cells(LastRowWs, c1).Address & ")"
            .Cells(LastRowWs + 2, c1 - 1) = "MODE"
            .Cells(LastRowWs + 2, c1).Formula = "=Mode(" & .Cells(2, c1).Address & ":" & .Cells(LastRowWs, c1).Address & ")"
            .Cells.EntireColumn.AutoFit
        End With
    Next
'    wb1.Close savechanges = True
'    Set ws = Nothing
'    Set wb1 = Nothing
    MsgBox "Done"
End Sub

Open in new window

FormatRawData.xls

Author

Commented:
yep that's what I want , but I would also like to have a new sheet at the end with the result of all the sheets( all the median and mode)
Ah Ok. Few more moments.

Sid

Author

Commented:
:)
Unlock this solution with a free trial preview.
(No credit card required)
Get Preview
Let me know if you want to change the format for Sheet Summary to

SheetName     Median
                        Mode

from

SheetName,Median,Mode

Sid

Author

Commented:
no it's perfect . it works well.

Thank you so much , great job!!!
You are welcome :)

Sid

Author

Commented:
Hi Sid,
I guess I have more to it. I need to add the total of each jobs, and have it on the bottom and also on the summary page that you created.
I am opening a new question right now.
Thanks
David
Unlock the solution to this question.
Thanks for using Experts Exchange.

Please provide your email to receive a free trial preview!

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.