提取数据报告表

这里是我的情况的问题：从第一个月，直到15日我的工作簿计数。（表1-15）有时会发生在半个月内有3个星期的计数。星期一至星期日以优异成绩计算。注意：由于使用日期，我隐藏了一些行和列。提取数据报告表

现在我应该用VB建立是月度报告显示我有多少就业岗位每位员工都有做由于使workspeed /作业的计算。所有作业是可变的，可在德工作簿（每天可以选择看到列出的作业表（1）.thisworkbook。这可能是我必须给评价周报，所以它是nessecery是VB WIL仍然使用相同wbnew，并扩大日常工作时间的输入我已经做了一个“部分”代码，但我无法处理其他问题代码应该查找有多少员工（这是我填写的工作表（“1”）的工作簿）

它应该在每个工作日片（“1”），折叠（“15）： •该员工存在 •板材笏一天我们都 •？它完成了哪些工作（清单中的工作描述+编码工作） •如果作业已经存在，只需在同一行中填写，但在日期的右栏中，如果作业尚未完成，请不要显示作业名称，不要显示作业代码 •多少时间花在工作 •要控制，如果计数是正确的，你可以看到总的时间在每月的reportsheet 的工作簿和CEL（“S15”）的片材（“15”）列（AA）（在这种情况下显示都有15小时=好）。

我有一个工作簿和一个报告张贴的例子。在工作簿中，您会发现我也试图从代码开始（请参见备注）希望有人能帮助我。

dowloadlink Workbooks klick here first

这里是我的attemps，但它远不是我真正需要做的

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

为了以建设性的方式开始的地方，你可以在下面找到

第二attemt

'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帮助我与此。

在此先感谢...

来源

2015-04-06 user2151190

有人正在寻找这个职位的解决方案吗？如果不是，我想删除这个问题，并提出一个新的问题，因为我找到了解决方案的一部分。我的新问题不会比这个问题复杂。请告诉我。如果明天在中欧时间12点00分没有人回答我无论如何都要删除这篇文章。提前致谢。 – user2151190

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

一旦你转移到一个工作表中您可以将数据全部通过第二宏将数据复制到单独的基于对人的名字页上的行循环。

这涉及到技术的VBA中使用循环来评估和许多标签从一个工作表复制的行之一的第一关，然后多在第二次量好。只用宏记录器就无法完成此操作。如果你要面对挑战，但缺乏VBA语言和Excel对象模型的知识，那么我建议让John Walkenbach关于Excel Power Programming with VBA的书籍之一。

好运。

来源

2015-04-11 02:00:48 rgo

您好，非常感谢您的快速回复。我可以设法创建工作簿了。现在我必须找到循环浏览页面并将它们放在正确位置的方法。这就是为什么我想打开一个新的线索。我将首先做一些功课:-) – user2151190

这位作者使verry方便的书！非常感谢！ – user2151190

提取数据报告表

回答

相关问题