将各个单元格从一个工作表复制到另一个工作表，单元格每周都不同

时间：2017-03-21 14:51:58

标签： vba excel-vba excel

我使用宏的知识扩展到仅记录我需要的内容，但是，使用此方法对复制和粘贴的内容有限制。 Proposed Future Work CopySheet 每个星期完成标准后，TE和YR被分配给一个能力...... CAP，DES，TE＆amp;中的蓝色细胞。然后YR需要复制和粘贴（但仅在分配了TE的情况下）到下一个空白行（阴影区域）... CPC PasteSheet 我使用的代码如下： Sub DataTransfer（） ＆＃39; ＆＃39; DataTransfer宏 ＆＃39;转移建议到CPC ＆＃39; 

Range("B9:L309").Select

ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
    Range("K10:K309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
    Range("L10:L309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
    Range("B10:B309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
With ActiveWorkbook.Worksheets("Proposed Future Work").Sort
    .SetRange Range("B9:L309")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Rows("12:26").Select
Selection.EntireRow.Hidden = True
ActiveWindow.SmallScroll Down:=-18
Range("K10:L11").Select
Selection.Copy
Sheets("CPC-Salam").Select
Range("BD19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Sheets("Proposed Future Work").Select
Range("B10:C11").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("CPC-Salam").Select
Range("B19:C20").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("B9:BU308").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("CPC-Salam").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("CPC-Salam").Sort.SortFields.Add Key:=Range( _
    "BD10:BD308"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("CPC-Salam").Sort.SortFields.Add Key:=Range( _
    "BE10:BE308"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
ActiveWorkbook.Worksheets("CPC-Salam").Sort.SortFields.Add Key:=Range( _
    "B10:B308"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("CPC-Salam").Sort
    .SetRange Range("B9:BU308")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Range("A10").Select
Sheets("Proposed Future Work").Select
Range("B10:L11").Select
Selection.ClearContents
Rows("11:27").Select
Selection.EntireRow.Hidden = False
Range("B9:L309").Select
ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
    Range("K10:K309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
    Range("L10:L309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
    Range("B10:B309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
    :=xlSortNormal
With ActiveWorkbook.Worksheets("Proposed Future Work").Sort
    .SetRange Range("B9:L309")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Rows("10:24").Select
Rows("10:24").EntireRow.AutoFit
Range("A10").Select

End Sub

欢迎任何建议

1 个答案:

答案 0 :(得分：0)

经过多次试验，我找到了我的vba问题的答案，并决定将其发布给任何其他人使用。

Sub DataTransfer()
'
' DataTransfer Macro
' Transfer Proposed to CPC
'

'Declare variables
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
'LRCT = Last Row in Copy Tab
    Dim LRCT As Integer
'FERPT = First Empty Row in Paste Tab
    Dim FERPT As Integer

'Set Variables
    Set sht1 = ThisWorkbook.Sheets("CPC")
    Set sht2 = ThisWorkbook.Sheets("Proposed Future Work")

'Stop the screen flickering
'    With Application
'        .ScreenUpdating = False
'    End With

'Apply sort to sheet2
    sht2.Range("B9:M309").Select
    ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
        Range("L10:L309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
        Range("M10:M309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
        Range("B10:B309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Proposed Future Work").Sort
        .SetRange Range("B9:M309")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'Find the last row with data in column K, sheet 2
    With sht2
    LRCT = .Cells(.Rows.Count, "L").End(xlUp).Row
    End With

'Find the first empty row in column BD, sheet 1
    With sht1
    FERPT = .Cells(.Rows.Count, "BD").End(xlUp).Row
    FERPT = FERPT + 1
    End With

'Copy data in sheet 2, starting from cell K10 to the last cell in column L
    sht2.Range("L10:M" & LRCT).Copy
'Paste data into sheet 1 column BD, starting from the first empty cell in column BD.
    sht1.Range(("BD" & FERPT)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Copy data in sheet 2, starting from cell B10 to the last cell in column L
    sht2.Range("B10:C" & LRCT).Copy
'Paste data into column B sheet 1, starting from the first empty cell in column BD.
    sht1.Range(("B" & FERPT)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Clear clipboard
    Application.CutCopyMode = False

'Remove copied data from sheet 2
    sht2.Range("L10:M" & LRCT).ClearContents
    sht2.Range("B10:C" & LRCT).ClearContents

'sort data in sheet1
    Sheets("CPC").Select
    Range("B9:BV309").Select
    ActiveWorkbook.Worksheets("CPC").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("CPC").Sort.SortFields.Add Key:=Range( _
        "BD10:BD309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("CPC").Sort.SortFields.Add Key:=Range( _
        "BE10:BE309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("CPC").Sort.SortFields.Add Key:=Range( _
        "B10:B309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("CPC").Sort
        .SetRange Range("B9:BV309")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'sort data in sheet 2
    Sheets("Proposed Future Work").Select
    Range("B9:M309").Select
    ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
        Range("L10:L309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
        Range("M10:M309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Proposed Future Work").Sort.SortFields.Add Key:= _
        Range("B10:B309"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Proposed Future Work").Sort
        .SetRange Range("B9:M309")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'Update the screen
    With Application
        .ScreenUpdating = True
    End With

End Sub
相关问题
最新问题