提取數據報告表

這裏是我的情況的問題：從第一個月，直到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

提取數據報告表

回答

相關問題