Extract data from Excel workbook with specific pro

Question

Here is the problem in my situation: My workbook counts from the first of the month till the 15th. (sheet 1-15) Sometimes it happens that there are 3 weeks-counts in half a month. The weeks are counted from Monday till Sunday in de excell cels. NOTE: I have hidden some rows and columns due to work with dates.

Now what I should establish with VB is a monthly report that shows me on how many jobs each employeé has done due to make a calculation of workspeed/ job. All the jobs are variable and can be selected in each day of de workbook (see listed jobs sheets(1).thisworkbook. It is possible that I have to give weekly evaluations, so it is nessecery that VB wil still use the same wbnew and expand the input of the daily workhours. I already made a 'partial' code to start with but I can not handle to the rest. The code should look for how many employees there are. (this I fill in in sheet(“1”) of workbook).

It should look in each workday sheet (“1”) –sheet(“15) for: • Does the employee exist? • Wat day of sheet we are • Which jobs it has done (jobdescription + code job required in listing) • If job already exist just fill in in the same row, but in the right Colum of date, if the job is not done, don't show the jobname, don't show the jobcode • How many time spend on the job • To control if the counting is correct you can see the total of hours in column (AA) in sheet (“15”) of workbook and cel (“S15”) of montly reportsheet (in this case both have 15hours displayed = ok).

I have a workbook and a example of reportsheet posted. In the workbook you will find also my attemt to start with a code (see remarks) Hopefully someone can help me out.

dowloadlink Workbooks klick here first

here is my attemps but it is far from what I really need to do

Sub Macro1()
'
' Macro1 Macro
'
Dim wbNew As Workbook
      'I need here VBA to look for if the file "per 1-15 exists and don't create a new file but just exand the data
      'I need something like for each ws of thisworkbook
      'also the rest of the required formula is too difficult for me
      'Does the employee exist?
      'Wat day of sheet we are
      'Which jobs it has done (jobdescription + code job required in listing)
      'If job already exist just fill in in the same row, but in the right Colum of date, if the job is not done, don't show the jobname, don't show the jobcode
      'How many time spend on the job
      'To control if the counting is correct you can see the total of hours in column (AA) in sheet (“15”) of workbook and cel (“S15”) of montly reportsheet (in this case both have 15hours displayed = ok).
       'you can have a look at my example reportsheet

     ThisWorkbook.Sheets(1).Activate
     Range("A1:S53").Select
     Range("S53").Activate
     Selection.Copy

Set wbNew = Workbooks.Add

     wbNew.Sheets(1).Activate
     Range("A1:S53").Select

     Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False

     wbNew.Sheets(1).Select
     Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
     SkipBlanks:=False, Transpose:=False
     Range("A1").Select
     ActiveSheet.Paste


     ThisWorkbook.Sheets(1).Activate
     Range("C12").Select
     Application.CutCopyMode = False
     Selection.Copy

     wbNew.Sheets(1).Activate

     Range("C12").Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

     ThisWorkbook.Sheets("1").Activate

     Sheets("1").Select
     Range("B8").Select
     Application.CutCopyMode = False
     Selection.Copy

    wbNew.Sheets(1).Activate
    Range("M5").Select
    wbNew.Sheets(1).Paste

    Range("L7:Q7").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
    Formula1:="=$C$12"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

    Range("R7:S7").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
     Application.CutCopyMode = False
    Selection.NumberFormat = "0"

 With Selection.FormatConditions(1).Font
    .Bold = True
    .Italic = False
    .TintAndShade = 0
 End With

 With Selection.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
 End With

      Selection.FormatConditions(1).StopIfTrue = False

      Range("A1:S53").Select

      Application.CutCopyMode = False
      ActiveSheet.PageSetup.PrintArea = "$A$1:$S$53"
      Application.PrintCommunication = False


     Application.PrintCommunication = True
     ActiveSheet.PageSetup.PrintArea = "$A$1:$S$53"
     Application.PrintCommunication = False

With ActiveSheet.PageSetup

      .PrintHeadings = False
      .PrintGridlines = False
      .PrintComments = xlPrintNoComments
      .PrintQuality = 600
      .CenterHorizontally = False
      .CenterVertically = False
      .Orientation = xlPortrait
      .Draft = False
      .PaperSize = xlPaperA4
      .FirstPageNumber = xlAutomatic
      .Order = xlDownThenOver
      .BlackAndWhite = False
      .Zoom = False
      .FitToPagesWide = 1
      .FitToPagesTall = 1
      .PrintErrors = xlPrintErrorsDisplayed
      .OddAndEvenPagesHeaderFooter = False
      .DifferentFirstPageHeaderFooter = False
      .ScaleWithDocHeaderFooter = True
      .AlignMarginsHeaderFooter = True

  End With

       Application.PrintCommunication = True

   ' I also should hide row 13 , but it gives strage vieuws at the moment


    Sheets(1).Name = Range("M5").Value


     Sheets.Add After:=ActiveSheet

     ThisWorkbook.Sheets(1).Activate

       Range("A1:S53").Select
       Range("S53").Activate
       Selection.Copy

       wbNew.Sheets(2).Activate
       Range("A1:S53").Select

       Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
       SkipBlanks:=False, Transpose:=False

       wbNew.Sheets(2).Select
       Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
       SkipBlanks:=False, Transpose:=False
       Range("A1").Select
       ActiveSheet.Paste


       ThisWorkbook.Sheets(1).Activate
       Range("C12").Select
       Application.CutCopyMode = False
       Selection.Copy

       wbNew.Sheets(1).Activate

       Range("C12").Select
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

       ThisWorkbook.Sheets("1").Activate

       Sheets("1").Select
       Range("B9").Select
       Application.CutCopyMode = False
       Selection.Copy
       wbNew.Sheets(2).Activate
       Range("M5").Select
       wbNew.Sheets(2).Paste

       Range("L7:Q7").Select
       Selection.FormatConditions.Delete
       Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
       Formula1:="=$C$12"
       Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority

       Range("R7:S7").Select
       Selection.Copy
       Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
       Application.CutCopyMode = False
       Selection.NumberFormat = "0"

  With Selection.FormatConditions(1).Font
    .Bold = True
    .Italic = False
    .TintAndShade = 0
  End With

  With Selection.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 65535
    .TintAndShade = 0
  End With

       Selection.FormatConditions(1).StopIfTrue = False

       Range("A1:S53").Select

      Application.CutCopyMode = False
      ActiveSheet.PageSetup.PrintArea = "$A$1:$S$53"
      Application.PrintCommunication = False

       Application.PrintCommunication = True
       ActiveSheet.PageSetup.PrintArea = "$A$1:$S$53"
       Application.PrintCommunication = False

  With ActiveSheet.PageSetup

      .PrintHeadings = False
      .PrintGridlines = False
      .PrintComments = xlPrintNoComments
      .PrintQuality = 600
      .CenterHorizontally = False
      .CenterVertically = False
      .Orientation = xlPortrait
      .Draft = False
      .PaperSize = xlPaperA4
      .FirstPageNumber = xlAutomatic
      .Order = xlDownThenOver
      .BlackAndWhite = False
      .Zoom = False
      .FitToPagesWide = 1
      .FitToPagesTall = 1
      .PrintErrors = xlPrintErrorsDisplayed
      .OddAndEvenPagesHeaderFooter = False
      .DifferentFirstPageHeaderFooter = False
      .ScaleWithDocHeaderFooter = True
      .AlignMarginsHeaderFooter = True

  End With

       Application.PrintCommunication = True
 ' I also should hide row 13 , but it gives strage vieuws at the moment


       Sheets(2).Name = Range("M5").Value

 ' instead of writing "per 1-15" down here, I should refer to Range("R7").Value, but it is not working
 ' in Cel R7 there is written "per 1-15" as value now(I believe)

     ActiveWorkbook.SaveAs Filename:= _
    "C:\Path\" & "per 1-15" & " " & Format(Range("C12"), "mmm") & ".xlsx"
     FileFormat = xlOpenXMLWorkbook

      Range("A15").Select

     ActiveWindow.Close


End Sub

in order to start somewhere with a constructive way you can find a second attemt below

 'in order to start with a creation of a new workbook I should do some handlings first
 'I want to create a workbook where the names of the employees are shown , with in the sheetnames the names of the employees
 'in thisworkbook.sheet "1" there is a list of 30 names listed Column B8:B37, that I shoud copy into a new workbook


 Dim i                   As Long
 Dim StartRow            As Long
 Dim LastRow             As Long
 Dim wbnew               As Workbook
 Dim wsNew               As Worksheet


 'STARTING FROM THIS WORKBOOK
 'Set Start Row thisworkbook
   StartRow = 8
 'Set Last Row thisworkbook
   LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
   For i = StartRow To LastRow

 'copy the name into a cel "M5" of wbnew (see below)
    If .Range("B" & i).Value <> "NAME" Then

 ' if cel is empty do nothing
    If .Range("B" & i).Value <> "" Then
    On Error Resume Next

 'create new workbook
   Set wbnew = Workbooks.Add

 ' launch here the sheet routine below


 'wbnew sheet routine Handling---------------------------------------------------------
 'when in this specific cells there is written "Name" , that Cell should not be copied to a new sheet wbnew
 'when in cels B8:B37 there is written a name ,the code should make a new workbook (wbnew) with following procedures


 'this selection is always a copy from this specific sheet

     ThisWorkbook.Sheets(1).Activate
     Range("A1:S53").Select
     Range("S53").Activate
     Selection.Copy

 'here I need to write activate always the new sheet wbnew

     wbnew.Sheets(2).Activate
     Range("A1:S53").Select

     Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

 'here I need to write select always the new sheetwbnew

     wbnew.Sheets(2).Select
         Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=False
     Range("A1").Select
     ActiveSheet.Paste

 ' this has to stay like this

     ThisWorkbook.Sheets(1).Activate
     Range("C13").Select
     Application.CutCopyMode = False
     Selection.Copy

 'here I need to write select always the new sheet wbnew

     wbnew.Sheets(2).Activate

     Range("C13").Select
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False

     ThisWorkbook.Sheets("1").Activate

 ' this has to stay like this

     Sheets("1").Select
     Range("B9").Select
     Application.CutCopyMode = False
     Selection.Copy

 'here I need to write activate always the new sheet wbnew

     wbnew.Sheets(2).Activate
     Range("M5").Select
     wbnew.Sheets(2).Paste

     Range("L7:Q7").Select
     Selection.FormatConditions.delete
     Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
         Formula1:="=$C$13"
     Selection.FormatConditions (Selection.FormatConditions.Count).SetFirstPriority

 With Selection.FormatConditions(1).Font
         .Bold = True
         .Italic = False
         .TintAndShade = 0
  End With
 With Selection.FormatConditions(1).Interior
         .PatternColorIndex = xlAutomatic
         .Color = 65535
         .TintAndShade = 0
  End With
     Selection.FormatConditions(1).StopIfTrue = False

     Range("A1:S53").Select

     Application.CutCopyMode = False
     ActiveSheet.PageSetup.PrintArea = "$A$1:$S$53"
     Application.PrintCommunication = False
 With ActiveSheet.PageSetup
         .PrintTitleRows = ""
         .PrintTitleColumns = ""
  End With
     Application.PrintCommunication = True
     ActiveSheet.PageSetup.PrintArea = "$A$1:$S$53"
     Application.PrintCommunication = False
 With ActiveSheet.PageSetup
         .LeftHeader = ""
         .CenterHeader = ""
         .RightHeader = ""
         .LeftFooter = ""
         .CenterFooter = ""
         .RightFooter = ""
         .LeftMargin = Application.InchesToPoints(0.708661417322835)
         .RightMargin = Application.InchesToPoints(0.708661417322835)
         .TopMargin = Application.InchesToPoints(0.748031496062992)
         .BottomMargin = Application.InchesToPoints(0.748031496062992)
         .HeaderMargin = Application.InchesToPoints(0.31496062992126)
         .FooterMargin = Application.InchesToPoints(0.31496062992126)
         .PrintHeadings = False
         .PrintGridlines = False
         .PrintComments = xlPrintNoComments
         .PrintQuality = 600
         .CenterHorizontally = False
         .CenterVertically = False
         .Orientation = xlPortrait
         .Draft = False
         .PaperSize = xlPaperA4
         .FirstPageNumber = xlAutomatic
         .Order = xlDownThenOver
         .BlackAndWhite = False
         .Zoom = False
         .FitToPagesWide = 1
         .FitToPagesTall = 1
         .PrintErrors = xlPrintErrorsDisplayed
         .OddAndEvenPagesHeaderFooter = False
         .DifferentFirstPageHeaderFooter = False
         .ScaleWithDocHeaderFooter = True
         .AlignMarginsHeaderFooter = True
         .EvenPage.LeftHeader.Text = ""
         .EvenPage.CenterHeader.Text = ""
         .EvenPage.RightHeader.Text = ""
         .EvenPage.LeftFooter.Text = ""
         .EvenPage.CenterFooter.Text = ""
         .EvenPage.RightFooter.Text = ""
         .FirstPage.LeftHeader.Text = ""
         .FirstPage.CenterHeader.Text = ""
         .FirstPage.RightHeader.Text = ""
         .FirstPage.LeftFooter.Text = ""
         .FirstPage.CenterFooter.Text = ""
         .FirstPage.RightFooter.Text = ""
     End With

     Range("R7:S7").Select
     Selection.Copy
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
     Application.CutCopyMode = False
     Selection.NumberFormat = "0"

     Range("A4:H9").Select
     Selection.Copy
     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

     Rows("10:10").Select
     Selection.EntireRow.Hidden = True

     Application.PrintCommunication = True

 'the new sheet should be named to this specific cel value (this is the name we copied form sheet(1) from thisworkbook
 'now it is referring to a specific sheet of wbnew, but that is not ok, should be changed
     Sheets(2).Name = Range("M5").Value

     Range("A15").Select

 'later I have to Call here an other Sub in order to do aditional extractions

 Call sub_followlater

      wbnew.Activate

 'create a new sheet here
      set wsNew = wbNew.Sheets.Add After:=ActiveSheet

 'save the new workbook wbnew

         wbnew.SaveAs Filename:= _
    "C:\Path\" & "per 1-15" & " " & Format(Range("C13"), "mmmm") & " " & Format(Range("C13"), "YYYY") & ".xlsx"
     FileFormat = xlOpenXMLWorkbook
     ActiveWindow.Close

Hopefully someone is feeling challanged enouhg to help me out with this.

thanks in advance...

Answer 1

One solution is to write a macro that will copy the rows with data to another sheet, so you get all the entries for all jobs, all dates on one page. This will streamline the code because you will not be looking at blank rows for your report preparation.

Once you have the data all transferred to a single worksheet you can loop through the rows in a second macro that copies the data to separate pages based on the persons name.

This involves a good amount of skill in VBA using loops to evaluate and copy the rows from many tabs to one in the first pass, then from the one worksheet to many in the second pass. You will not be able to complete this with just the macro recorder. If you are up to the challenge but lacking in knowledge of the VBA language and the Excel object model I suggest getting one of John Walkenbach's books on Excel Power Programming with VBA.

Good luck.