asked on

Excel Macro

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/questions/26971985/Excel-Macro.html

Thanks in Advance.
David

SiddharthRout

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

taverny

ASKER

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)

SiddharthRout

Ah Ok. Few more moments.

Sid

taverny

ASKER

ASKER CERTIFIED SOLUTION

SiddharthRout

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SiddharthRout

Let me know if you want to change the format for Sheet Summary to

SheetName Median
Mode

from

SheetName,Median,Mode

Sid

taverny

ASKER

no it's perfect . it works well.

Thank you so much , great job!!!

SiddharthRout

You are welcome :)

Sid

taverny

ASKER

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