67393

Extract data from Excel workbook with specific procedure to report sheet

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.

<a href="https://app.box.com/s/i28kljmho7kngj236mwpzvcoeppuksuy" rel="nofollow">dowloadlink Workbooks klick here first</a>

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...

Answer1:

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.

Recommend

  • Copying Dynamic Rows Into New Workbook and save it
  • macro that auto-executes when sheet is opened
  • Excel 2007 VBA Zooming (without using select?)
  • Why does not field with custom function to get name recalculate?
  • Copy and Paste Entire Row
  • Unable to save a query as a view table
  • How to update powerpivot pivot table filter via cell reference?
  • What's a fast (non-loop) way to apply a dict to a ndarray (meaning use elements as keys and rep
  • Can I use worksheet_change for a specific column only?
  • Python multiprocessing of a sum
  • Cythonized function unexpectedly slow
  • Create a multiple screen android application
  • Upper limits for fibonnacci
  • Excel distinct count with conditions
  • remove unicode characters but keep all special and English characters with preg_replace
  • Double-click autofill - dynamic based on adjacent cell
  • Rodeo UnicodeDecodeError: 'ascii' codec can't decode byte 0xef in position 0: ordinal
  • several dataProvider per one Test in TestNG
  • Write output of for loop to multiple files
  • Python cosine function precision [duplicate]
  • Flash radiobutton: how do I get the selected radiobutton?
  • How do I retrieve the user information of a user authenticated with Apache's mod_ldap?
  • How can I restyle a word when rendering a pdf with pdf.js?
  • Conversion from string “a” to type 'Boolean' is not valid
  • Calling Worksheet functions from vba in foreign language versions of Excel
  • Excel's Macro-Recorder usage
  • Chrome doesn't support silverlight anymore? How to solve this?
  • Modifying destination and filename of gulp-svg-sprite
  • How to handle AllServersUnavailable Exception
  • VBA Convert delimiter text file to Excel
  • ORA-29908: missing primary invocation for ancillary operator
  • How to get next/previous record number?
  • Data Validation Drop Down Box Arrow Disappearing
  • How do you join a server to an Active Directory (domain)?
  • Angular 2 constructor injection vs direct access
  • Java static initializers and reflection
  • Android Google Maps API OnLocationChanged only called once
  • How does Linux kernel interrupt the application?
  • Reading document lines to the user (python)
  • UserPrincipal.Current returns apppool on IIS