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

Excel Macro

Hi Experts,
this is a question to the following answer.
http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_26972706.html#a35461141

I am trying to modify the macro to include an extra requirement , I would like to have the total numbers of line for each sheet in my spreadsheet , it can says: Total Job: ####
then on the Summary page I would like to have a column with the total jobs for each sheet as well.
I just want to be clear I only need the number of jobs not including the headers

Thanks
David
0
taverny
Asked:
taverny
  • 4
  • 3
1 Solution
 
byundtCommented:
You didn't post a workbook with test data, so I could not test the modifications. I assume that a COUNT function applied to the same column as being used for MEDIAN and MODE will give you the number of jobs.

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.Range("A1:D1") = Array("SHEETNAME", "MEDIAN", "MODE", "TOTAL JOB:")
    
    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(LastRowWs + 3, c1 - 1) = "TOTAL JOB:"
                .Cells(LastRowWs + 3, c1).Formula = "=COUNT(" & .Cells(2, c1).Address & ":" & .Cells(LastRowWs, c1).Address & ")"
                .Cells.EntireColumn.AutoFit
                
                ws1.Cells(LstRw, 1) = .Name
                ws1.Cells(LstRw, 2).Resize(1, 3) = Application.Transpose(.Cells(LastRowWs + 1, c1).Resize(3, 1).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

0
 
tavernyAuthor Commented:
Hy Byundt,
sorry , attached is the row data before the macro.
I will test your code right now .
thanks for the prompt response.
David
RawData.xls
0
 
byundtCommented:
David,
I found sample data here: http:/Q_26971985.html and the posted code seems to be working.

Brad
0
Independent Software Vendors: 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:
Thanks Brad it does work.
Thank you for your help.
David
0
 
tavernyAuthor Commented:
Hi Brad,

I am sorry to ask you that now and If it is out of the scope of this question , then I can open a new one.
I actually need the average as well between "totals Job " and "Mode", can you tell me what lines I need to add in my code.
Thanks in advance.
David
0
 
byundtCommented:
David,
I added AVERAGE to the code, with two decimal places.
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
    
    Application.ScreenUpdating = False
    Set wb1 = Workbooks.Open(FilePath)
    Set ws1 = wb1.Sheets.Add(after:=wb1.Sheets(Sheets.Count))
    ws1.Name = "Summary"
    ws1.Range("A1:E1") = Array("SHEETNAME", "MEDIAN", "MODE", "AVERAGE", "TOTAL JOB:")
    
    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(LastRowWs + 3, c1 - 1) = "AVERAGE"
                .Cells(LastRowWs + 3, c1).Formula = "=AVERAGE(" & .Cells(2, c1).Address & ":" & .Cells(LastRowWs, c1).Address & ")"
                .Cells(LastRowWs + 3, c1).NumberFormat = "#.00"
                .Cells(LastRowWs + 4, c1 - 1) = "TOTAL JOB:"
                .Cells(LastRowWs + 4, c1).Formula = "=COUNT(" & .Cells(2, c1).Address & ":" & .Cells(LastRowWs, c1).Address & ")"
                .Cells.EntireColumn.AutoFit
                
                ws1.Cells(LstRw, 1) = .Name
                ws1.Cells(LstRw, 4).NumberFormat = "#.00"
                ws1.Cells(LstRw, 2).Resize(1, 4) = Application.Transpose(.Cells(LastRowWs + 1, c1).Resize(4, 1).Value)
                LstRw = LstRw + 1
            End With
        End If
    Next
    ws1.Cells.EntireColumn.AutoFit
'    wb1.Close savechanges = True
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub

Open in new window


Brad
0
 
tavernyAuthor Commented:
That is perfect , thank you again Brad , I think I understood how you do it.
0

Featured Post

Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

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