从目标中删除行时从源表更新行到目标表

时间：2014-03-07 23:07:29

标签： excel excel-vba vba

道歉，这有点长。

背景：

我正在运行一个调用其他子模块的主子模块。名为UpdateMatrix的子模块无法正常工作。以下是完整的代码。这是过程：

另一个人将在“优先级列表”表中写完成/完成。 另一个人将在“优先级列表”表中写入输入新项目。

所以我想要我的主模块：

1）将完成/完成的项目从“优先级列表”移动到“完成的项目”表

2）对于“优先级列表”中的新项目，在“优先级列表”中的特定列中计算正确的摘要编号

3）将新项目从“优先级列表”复制到“优先级矩阵”，同时保留“优先级矩阵”的格式，并从“优先级矩阵”中删除完成/完成项目（我试图清除表格，但也许那效率太低了？）

“优先级矩阵”还包含基于此新数据的图表

4）在“优先级矩阵”中添加条件格式，根据其重要性和紧急度为项目添加颜色。

问题：

  1. 我不知道如何清除“优先级矩阵”的内容，然后使用正确的格式（从上面的行复制和插入）和“优先级列表”中的现有行重新填充它，“优先级列表”仅包含正在进行和新项目的行（旧项目已移至“已完成项目”）。在“优先级矩阵”中，我想使用Insert而不是PasteSpecial，因为行具有特殊格式（公式，边框和单元格条形图）。

  2. Sub UpdateMatrix（）存在关于没有对象存在的错误。

    3. 该错误特别针对此行，但我也不知道如何根据“优先级列表”中的项目数动态复制和插入：

    'For j=7 to maxrow in "Matrix", clear the contents from K7 to maxrow for "Matrix"

Worksheets("Prioritization Matrix").Range("K7", Range("V" & ActiveSheet.Rows.Count)).ClearContents

I changed it to the following, but it is not dynamic, and I'd prefer not to have this code.

Worksheets("Prioritization Matrix").Range("K7", "O300").ClearContents

    下面是一个很麻烦的子模块：

    '问题是UPDATEMATRIX

    Sub UpdateMatrix（）

    Application.ScreenUpdating = False
Application.ActiveSheet.UsedRange

Dim MaxRowList As Long
Dim i As Long

MaxRowList = Worksheets("Prioritization List").UsedRange.Rows.Count

'Copy row in Matrix to a new row in Matrix up to number of MaxRowList

For j = 7 To MaxRowList
    If Worksheets("Prioritization Matrix").UsedRange.Cells(j, 11).Value = "" Then
        Worksheets("Prioritization Matrix").UsedRange.Cells(j, 11).End(xlUp).Select
        Rows(Selection.Row - 1).Copy
        Rows(Selection.Row).Insert Shift:=xlDown
    End If
Next j


'For j=7 to maxrow in "Matrix", clear the contents on column k to v
Worksheets("Prioritization Matrix").Range("K7", "O300").ClearContents


'For each row until MaxRowList, copy cells from List to Matrix

For i = 7 To MaxRowList

    Sheets("Prioritization List").Select
    Cells(i, 3).Select
    Selection.Copy
    Sheets("Prioritization Matrix").Select
    Cells(i, 11).PasteSpecial Paste:=xlPasteValues

    Sheets("Prioritization List").Select
    Cells(i, 6).Select
    Selection.Copy
    Sheets("Prioritization Matrix").Select
    Cells(i, 12).PasteSpecial Paste:=xlPasteValues

    Sheets("Prioritization List").Select
    Cells(i, 7).Select
    Selection.Copy
    Sheets("Prioritization Matrix").Select
    Cells(i, 13).PasteSpecial Paste:=xlPasteValues

    Sheets("Prioritization List").Select
    Cells(i, 24).Select
    Selection.Copy
    Sheets("Prioritization Matrix").Select
    Cells(i, 14).PasteSpecial Paste:=xlPasteValues

Next i

Application.ScreenUpdating = True

    End Sub

    '这是整个模块 - 主模块运行子模块

    Sub Master()
    Call MoveOldProjects
    Call AddFormulaList
    Call UpdateMatrix
    Call AddConditionMatrix
End Sub

Sub MoveOldProjects()

    Application.ScreenUpdating = False

    Dim x As Long
    Dim iCol As Integer
    Dim MaxRowList As Long
    Dim S As String

    Set wsSource = Worksheets("Prioritization List")
    Set wsTarget = Worksheets("Finished Projects")

    iCol = 1
    MaxRowList = wsSource.Cells(Rows.Count, iCol).End(xlUp).Row

    For x = MaxRowList To 1 Step -1
        S = wsSource.Cells(x, 1)
        If S = "Done" Or S = "done" Then
            AfterLastTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
            wsSource.Rows(x).Copy
            wsTarget.Rows(AfterLastTarget).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            wsSource.Rows(x).Delete
        End If
    Next

   Application.ScreenUpdating = True

End Sub

Sub AddFormulaList()

    ActiveWorkbook.Sheets("Prioritization List").Activate
    Application.ScreenUpdating = False
    Application.ActiveSheet.UsedRange

    Dim MaxRowList As Long
    Dim NumNewProj As Integer

    MaxRowList = Worksheets("Prioritization List").UsedRange.Rows.Count 'Count new # rows after new projects added
    NumNewProj = 0 'Counts new number of projects based on counting rows with empty cells; same as MaxRow - NumOldProj = NewNewProj

    'For all rows in maxrow,
    'If column 6 is empty, copy cell above, and paste into empty cell
    'Then add 1 to counter of new row called NumNewProj

    For i = 7 To MaxRowList

        'Importance
        If Worksheets("Prioritization List").UsedRange.Cells(i, 6).Value = "" Then
            Worksheets("Prioritization List").UsedRange.Cells(i, 6).End(xlUp).Select
            Selection.Copy
            ActiveCell.Offset(1, 0).Activate
            Selection.PasteSpecial Paste:=xlPasteFormulas
            NumNewProj = NumNewProj + 1 'Counter to count number of empty rows
        End If

        'Urgency
        If Worksheets("Prioritization List").UsedRange.Cells(i, 7).Value = "" Then
            Worksheets("Prioritization List").UsedRange.Cells(i, 7).End(xlUp).Select
            Selection.Copy
            ActiveCell.Offset(1, 0).Activate
            Selection.PasteSpecial Paste:=xlPasteFormulas
        End If

        'Unweighted
        If Worksheets("Prioritization List").UsedRange.Cells(i, 21).Value = "" Then
            Worksheets("Prioritization List").UsedRange.Cells(i, 21).End(xlUp).Select
            Selection.Copy
            ActiveCell.Offset(1, 0).Activate
            Selection.PasteSpecial Paste:=xlPasteFormulas
        End If

        'Number of Month since Submission
        If Worksheets("Prioritization List").UsedRange.Cells(i, 23).Value = "" Then
            Worksheets("Prioritization List").UsedRange.Cells(i, 23).End(xlUp).Select
            Selection.Copy
            ActiveCell.Offset(1, 0).Activate
            Selection.PasteSpecial Paste:=xlPasteFormulas
        End If

        'Project Age
        If Worksheets("Prioritization List").UsedRange.Cells(i, 24).Value = "" Then
            Worksheets("Prioritization List").UsedRange.Cells(i, 24).End(xlUp).Select
            Selection.Copy
            ActiveCell.Offset(1, 0).Activate
            Selection.PasteSpecial Paste:=xlPasteFormulas
        End If

    Next i

    'MsgBox NumNewProj
    Application.ScreenUpdating = True

End Sub

Sub UpdateMatrix()

    Application.ScreenUpdating = False
    Application.ActiveSheet.UsedRange

'VARIABLES

    Dim MaxRowList As Long
    Dim i As Long

    MaxRowList = Worksheets("Prioritization List").UsedRange.Rows.Count

'EXECUTION

    'Copy row in Matrix to a new row in Matrix up to number of MaxRowList

    For j = 7 To MaxRowList
        If Worksheets("Prioritization Matrix").UsedRange.Cells(j, 11).Value = "" Then
            Worksheets("Prioritization Matrix").UsedRange.Cells(j, 11).End(xlUp).Select
            Rows(Selection.Row - 1).Copy
            Rows(Selection.Row).Insert Shift:=xlDown
        End If
    Next j


    'For j=7 to maxrow in "Matrix", clear the contents on column k to v
    Worksheets("Prioritization Matrix").Range("K7", Range("V" &    
    ActiveSheet.Rows.Count)).ClearContents


    'For each row until MaxRowList, copy cells from List to Matrix

    For i = 7 To MaxRowList

        Sheets("Prioritization List").Select
        Cells(i, 3).Select
        Selection.Copy
        Sheets("Prioritization Matrix").Select
        Cells(i, 11).PasteSpecial Paste:=xlPasteValues

        Sheets("Prioritization List").Select
        Cells(i, 6).Select
        Selection.Copy
        Sheets("Prioritization Matrix").Select
        Cells(i, 12).PasteSpecial Paste:=xlPasteValues

        Sheets("Prioritization List").Select
        Cells(i, 7).Select
        Selection.Copy
        Sheets("Prioritization Matrix").Select
        Cells(i, 13).PasteSpecial Paste:=xlPasteValues

        Sheets("Prioritization List").Select
        Cells(i, 24).Select
        Selection.Copy
        Sheets("Prioritization Matrix").Select
        Cells(i, 14).PasteSpecial Paste:=xlPasteValues

    Next i

    Application.ScreenUpdating = True

End Sub

Sub AddConditionMatrix()

    ActiveWorkbook.Sheets("Prioritization Matrix").Activate
    Application.ScreenUpdating = False
    Application.ActiveSheet.UsedRange

    Dim MaxRowMatrix As Long

    MaxRowMatrix = Worksheets("Prioritization Matrix").UsedRange.Rows.Count

    'AddConditionMatrix
    For i = 7 To MaxRowMatrix

            If Cells(i, 12).Value < 50 Or Cells(i, 13).Value < 50 Then
                Cells(i, 11).Interior.ColorIndex = 43 'Green
            End If

            If (Cells(i, 12).Value > 50 And Cells(i, 12).Value < 62.5) Or (Cells(i, 13).Value > 50 And Cells(i, 13).Value < 62.5) Then
                Cells(i, 11).Interior.ColorIndex = 6 'Yellow
            End If

            If (Cells(i, 12).Value > 62.5 And Cells(i, 12).Value < 75) Or (Cells(i, 13).Value > 62.5 And Cells(i, 13).Value < 75) Then
                Cells(i, 11).Interior.ColorIndex = 40 'Light Orange
            End If

            If (Cells(i, 12).Value > 75 And Cells(i, 12).Value < 87.5) Or (Cells(i, 13).Value > 75 And Cells(i, 13).Value < 87.5) Then
                Cells(i, 11).Interior.ColorIndex = 46 'Dark Orange
            End If

            If (Cells(i, 12).Value > 87.5 Or Cells(i, 13).Value > 87.5) Then
                Cells(i, 11).Interior.ColorIndex = 3 'Red
            End If

    Next i

    Application.ScreenUpdating = True

End Sub

0 个答案:

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