从多个页面复制和粘贴数据 - 最后一个代码添加一个随机的superfluos行

时间：2018-06-07 19:10:45

标签： google-sheets copying

当从多张表中复制和粘贴不同的信息集时，代码会一直有效，直到最后一步找到并拉入预算日期。在这一点上，我得到了一行额外的信息，这些信息是从我的摘要表A6-F6行中随机抽取的。当逐步执行每组代码时，所有代码都能正确地单独工作，直到我用最后一组拉出第一组（拉入风险数据），这就是随机数据出现的地方。此外，我是VBA的新手，所以我想我可以创建查找数据的循环，然后查找相同数据的项目名称（保存在工作表上的不同行但每个工作表上的相同单元格）稍微有点滑...... 

Sub Copy_ProjectSummaryData()

Application.ScreenUpdating = False

Dim i As Integer
Dim ws_num As Integer
Dim rng As Range, destRow As Long
Dim starting_ws As Worksheet
Dim shtDest As Worksheet
Dim c As Range
Dim startdate As Date
Dim enddate As Date

Set starting_ws = ThisWorkbook.Worksheets(1) 'remember which worksheet is 
active in the beginning
ws_num = ThisWorkbook.Worksheets.Count

Set shtDest = Sheets("Summary")

destRow = 4 'start copying Risks to this row
destRow2 = 4 'start copying Risk Project Name to this row
destRow3 = 4 'start copying Issues to this row
destRow4 = 4 'start copying Issues Project Name to this row
destRow5 = 4 'start copying Milestones to this row
destRow6 = 4 'start copying Milestone Project Name to this row
destRow7 = 4 'start copying Budget Data to this row
destRow8 = 4 'start copying Budget Project Name to this row

startdate = ThisWorkbook.Worksheets("Summary").Range("F1")
enddate = ThisWorkbook.Worksheets("Summary").Range("H1")

'Clear contents from sheet before running new report
  Range("A4:AG4").Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.ClearContents



'FIND AND PULL IN ESCALATED RISKS WITHIN THE DATE RANGE FOR THE REPORT
For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate

    Set rng = 
Application.Intersect(ThisWorkbook.Worksheets(i).Range("G16:G20"), 
ThisWorkbook.Worksheets(i).UsedRange)
    For Each c In rng.Cells
         If c.Value >= startdate And c.Value <= enddate Then
        'Starting 6 cells to the left of c (col A),
        '  copy an 8-cell wide block to the other sheet,
        '  pasting it in Col B on row destRow
        c.Offset(0, -6).Resize(1, 8).Copy _
        shtDest.Cells(destRow, 2)
        destRow = destRow + 1
      End If
    Next

Next

'Find and paste Risk Project Name
For i = 1 To ws_num

ThisWorkbook.Worksheets(i).Activate

Set rng = Application.Intersect(ThisWorkbook.Worksheets(i).Range("G16:G20"), 
ThisWorkbook.Worksheets(i).UsedRange)
For Each c In rng.Cells
    If c.Value >= startdate And c.Value <= enddate Then
    '  copy C3 to the other sheet,
    '  pasting it in Col A on row destRow
    Range("C3").Copy _
    shtDest.Cells(destRow2, 1)
    destRow2 = destRow2 + 1
    End If
Next
Next



'FIND AND PULL IN NEW ISSUES WITHIN THE DATE RANGE FOR THE REPORT

For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate

    Set rng = 
Application.Intersect(ThisWorkbook.Worksheets(i).Range("G22:G26"), 
ThisWorkbook.Worksheets(i).UsedRange)
    For Each c In rng.Cells
         If c.Value >= startdate And c.Value <= enddate Then
        'Starting 6 cells to the left of c (col A),
        '  copy an 8-cell wide block to the other sheet,
        '  pasting it in Col B on row destRow
        c.Offset(0, -6).Resize(1, 8).Copy _
        shtDest.Cells(destRow3, 11)
        destRow3 = destRow3 + 1
      End If
    Next

Next

'Find and paste Issues Project Name
For i = 1 To ws_num

ThisWorkbook.Worksheets(i).Activate

Set rng = Application.Intersect(ThisWorkbook.Worksheets(i).Range("G22:G26"), 
ThisWorkbook.Worksheets(i).UsedRange)
For Each c In rng.Cells
    If c.Value >= startdate And c.Value <= enddate Then
    '  copy C3 to the other sheet,
    '  pasting it in Col A on row destRow
    Range("C3").Copy _
    shtDest.Cells(destRow4, 10)
    destRow4 = destRow4 + 1
    End If
Next
Next




'FIND AND PULL IN MILESTONES WITHIN THE DATE RANGE FOR THE REPORT

For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate

    Set rng = 
Application.Intersect(ThisWorkbook.Worksheets(i).Range("D10:D13"), 
ThisWorkbook.Worksheets(i).UsedRange)
    For Each c In rng.Cells
         If c.Value >= startdate And c.Value <= enddate Then
        'Starting 3 cells to the left of c (col D),
        '  copy an 8-cell wide block to the other sheet,
        '  pasting it in Col T on row destRow
        c.Offset(0, -3).Resize(1, 8).Copy _
        shtDest.Cells(destRow5, 20)
        destRow5 = destRow5 + 1
      End If
    Next
Next

'Find and paste Milestone Project Name
For i = 1 To ws_num

ThisWorkbook.Worksheets(i).Activate

Set rng = Application.Intersect(ThisWorkbook.Worksheets(i).Range("D10:D13"), 
ThisWorkbook.Worksheets(i).UsedRange)
For Each c In rng.Cells
    If c.Value >= startdate And c.Value <= enddate Then
    '  copy C3 to the other sheet,
    '  pasting it in Col S on row destRow
    Range("C3").Copy _
    shtDest.Cells(destRow6, 19)
    destRow6 = destRow6 + 1
    End If
Next
Next




'FIND AND PULL IN BUDGET DATA WITHIN THE DATE RANGE FOR THE REPORT

For i = 1 To ws_num
ThisWorkbook.Worksheets(i).Activate
If ("E6") >= Date Then
Range("E6").Offset(0, -4).Resize(1, 8).Copy _
        shtDest.Cells(destRow7, 26)
        destRow7 = destRow7 + 1
      End If


Next

'Find and paste Budget Project Name
For i = 1 To ws_num

ThisWorkbook.Worksheets(i).Activate
If ("E6") >= Date Then
Range("C3").Copy _
    shtDest.Cells(destRow8, 25)
    destRow8 = destRow8 + 1
    End If
Next



starting_ws.Activate 'activate the worksheet that was originally active



Range("B4").Select
Selection.Copy
Range("A4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False


Range("K4").Select
Selection.Copy
Range("J4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False


Range("T4").Select
Selection.Copy
Range("S4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False


Range("T4").Select
Selection.Copy
Range("Y4:AJ4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False


Range("X5").Select
Selection.Copy
Range("Y4:AI4").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Range("V5").Select
Selection.Copy
Range("AA4:AD4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

'ActiveSheet.PageSetup.printarea = Range("A4:AI30")


End Sub

0 个答案:

没有答案
相关问题
最新问题