从Excel工作簿中提取数据，并使用特定的过程来报告工作表

Question

这是我的情况中的问题： 我的工作簿从本月的第一天开始计算到15日。 （表1-15） 有时会发生在半个月内有3个星期的计数。 这些周从周一到周日在de excell cels计算。 注意：由于使用日期，我隐藏了一些行和列。

现在我应该用VB建立的是一份月度报告，它向我展示了每位员工因计算工作量/工作而完成的工作量。 所有工作都是可变的，可以在工作簿的每一天选择（参见列出的工作表（1）.thisworkbook。 我可能需要每周进行一次评估，因此VB仍然会使用相同的wbnew并扩展日常工作时间的输入。 我已经制作了一个“部分”代码，但我无法处理剩下的代码。 代码应该查找有多少员工。 （这是我填写工作簿的表（“1”）。

它应该在每个工作日表（“1”） - 表（“15”）中查找： •员工是否存在？ •我们的工作日 •它完成了哪些工作（工作描述+列表中需要的代码工作） •如果作业已存在，则只需填写同一行，但在右侧Colum of date中，如果作业未完成，则不显示作业名称，不显示作业代码 •在工作上花了多少时间 •要控制计数是否正确，您可以看到工作簿的工作表（“15”）中的列（AA）和montly报表中的cel（“S15”）的总小时数 （在这种情况下，两者都显示15小时=好）。

我有一个工作簿和发布的报告表示例。 在工作簿中，您还可以找到我的attemt以代码开头（请参阅备注） 希望有人可以帮助我。

dowloadlink Workbooks klick here first

这是我的尝试，但它远非我真正需要做的事情

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

希望有人能够帮助我解决这个问题。

提前感谢...

Answer 1

一种解决方案是编写一个宏，将带有数据的行复制到另一个工作表，这样您就可以获得所有工作的所有条目，一个页面上的所有日期。这将简化代码，因为您不会为报告准备工作查看空白行。

将数据全部传输到单个工作表后，您可以循环遍历第二个宏中的行，该宏根据人员名称将数据复制到单独的页面。

这涉及VBA中的大量技能，使用循环来评估和复制第一遍中的许多选项卡中的行，然后从第一遍中的一个工作表复制到许多选项卡。仅使用宏录制器，您将无法完成此操作。如果您能够应对挑战但缺乏VBA语言和Excel对象模型的知识，我建议您使用VBA获取John Walkenbach的Excel Power Programming中的一本书。

祝你好运。