从Excel工作簿中提取数据并使用特定的过程来报告工作表
这是我的情况：我的工作簿从本月的第一个月开始计算，直到第十五天。 （表1-15）有时会发生在半个月内有3个星期的计数。 从星期一到星期天，这些星期的数字都是非常好的。 注意：由于使用date，我隐藏了一些行和列。
现在我应该用VB来build立一个月度报告，通过这个月度报告可以看出每个工作人员做了多less工作，以计算工作速度/工作量。 所有的工作都是可变的，可以在工作日的每一天select（见工作表（1）.thisworkbook。可能我必须给每周评估，所以VB是仍然使用相同的wbnew和nessecery扩大日常工作时间的input，我已经做了一个“部分”的代码，但是我不能处理其余的代码，代码应该查找有多less员工（这个我填写工作表（“1” ）的工作簿）。
它应该在每个工作表（“1”） – 表格（“15）”中查找：•员工是否存在？ •我们工作表的一天•它做了哪些工作（工作描述+编码工作需要在列表中）•如果工作已经存在，只需填写在同一行，但在date的右栏中，如果工作没有完成，不显示作业名称•不显示作业代码•在作业上花费多less时间•要控制计数是否正确，可以在工作簿的工作表（“15”）的列（AA）中看到小时数的总和和cel（“S15”）的报告单（在这种情况下都有15小时显示= ok）。
我有一个工作簿和一个报告张贴的例子。 在工作簿中，你会发现我也试图从一个代码开始（请参阅备注）希望有人能帮助我。
dowloadlink工作簿首先在这里点击
这里是我的尝试，但这远远不是我真正需要做的
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 为了以build设性的方式开始某个地方，你可以在下面find第二个尝试
'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
希望有人觉得挑衅enouhg帮助我与此。
提前致谢…
一种解决方法是编写一个macros，将数据行复制到另一个表中，以便获取所有作业的所有条目，所有date都在一个页面上。 这将简化代码，因为您不会为了准备报告而查看空行。
将所有数据传输到单个工作表后，您可以遍历第二个macros中的行，这些macros将数据复制到基于人员姓名的单独页面中。
这涉及VBA中的大量技巧，使用循环来评估和复制第一遍中的许多标签中的行，然后在第二遍中从一个工作表到多个标签。 只有macroslogging器，你将无法完成这一点。 如果你面临的挑战，但缺乏VBA语言和Excel对象模型的知识，我build议约翰·沃肯巴赫的一本Excel电源编程与VBA的书。
祝你好运。