• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 255
  • Last Modified:

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 .
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_26971985.html


Thanks in Advance.
David
0
taverny
Asked:
taverny
  • 5
  • 4
1 Solution
 
SiddharthRoutCommented:
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
0
 
tavernyAuthor 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)
0
 
SiddharthRoutCommented:
Ah Ok. Few more moments.

Sid
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
tavernyAuthor Commented:
:)
0
 
SiddharthRoutCommented:
Here is the updated code and a sample file.

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, ws1 As Worksheet
    Dim LastRowWs As Long, c1 As Long, i As Long, LstRw 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)
    Set ws1 = wb1.Sheets.Add(after:=wb1.Sheets(Sheets.Count))
    ws1.Name = "Summary"
    ws1.Cells(1, 1) = "SHEETNAME"
    ws1.Cells(1, 2) = "MEDIAN"
    ws1.Cells(1, 3) = "MODE"
    LstRw = 2
    
    For Each ws In wb1.Worksheets
        If ws.Name <> "Summary" Then
            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
                
                ws1.Cells(LstRw, 1) = .Name
                ws1.Cells(LstRw, 2) = .Cells(LastRowWs + 1, c1).Value
                ws1.Cells(LstRw, 3) = .Cells(LastRowWs + 2, c1).Value
                LstRw = LstRw + 1
            End With
        End If
    Next
    ws1.Cells.EntireColumn.AutoFit
'    wb1.Close savechanges = True
'    Set ws = Nothing
'    Set ws1 = Nothing
'    Set wb1 = Nothing
    MsgBox "Done"
End Sub

Open in new window

FormatRawData.xls
0
 
SiddharthRoutCommented:
Let me know if you want to change the format for Sheet Summary to

SheetName     Median
                        Mode

from

SheetName,Median,Mode

Sid
0
 
tavernyAuthor Commented:
no it's perfect . it works well.

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

Sid
0
 
tavernyAuthor 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
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 5
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now