Кодирование VBA помогает искать значения элементов, копировать их и вставлять в другой лист вместе с добавлением строк. - PullRequest
Новая
       0

Кодирование VBA помогает искать значения элементов, копировать их и вставлять в другой лист вместе с добавлением строк.

0 голосов
/ 06 января 2020

Привет, я довольно новичок в кодировании VBA. Я пытаюсь создать VBA, который выполняет следующие действия:

  1. Копирует номера задач из столбца A на листе 1 в столбец A на листе 2
  2. Если эта задача имеет соответствующее количество в столбце M на листе 1 он копирует эту сумму на листе в sheet2
  3. Если в задаче есть 5, 10 или даже 20 подзадач на листе 1, следует добавить столько строк (не данных, а только строк) в листе 2 перед вставкой итогового столбца.

Пока у меня есть этот код записан и его функционирование. Он находит номера моих задач на листе 1, находит соответствующие суммы и также вставляет их значения на лист 2. Единственная проблема заключается в том, что он добавляет только 5 строк на лист 2 вместо общего количества строк, которые моя задача содержит на листе 1 .

Если кто-нибудь здесь может дать мне несколько советов о том, как я могу отредактировать код ниже, чтобы мой VBA добавил достаточно строк на листе 2, что было бы очень полезно! 

    Option Explicit

Sub Update_Asset_Information()

Dim Range_Alpha As Range
Dim Range_Bravo As Range
Dim Range_Charlie As Range
Dim Range_Delta As Range
Dim Cell_Alpha As Range
Dim Cell_Bravo As Range
Dim Cell_Charlie As Range
Dim Cell_Delta As Range
Dim WS As Worksheet

Dim FirstRow As Long
Dim LastRow As Long
Dim FinalRow As Long
Dim RowCount As Long
Dim RowsToInsert As Long
Dim i As Long
Dim r As Long

FirstRow = 2
RowCount = 1
RowsToInsert = 5



'//////Disable application functions to speed up VBA runtime

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False

'//////Clear cell contents and formatting

Worksheets("Asset Information").Activate
Range("A8:P1000").Select
    Selection.FormatConditions.Delete
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.ClearContents
    Selection.Interior.ColorIndex = 2

With Range("D8:D1000").Validation
.Delete

End With

With Range("E8:E1000").Validation
.Delete

End With

Worksheets("Scratch Paper").Visible = True
Worksheets("Tables").Visible = True
Worksheets("Scratch Paper").Activate
Range("A2:A1000").Select
    Selection.FormatConditions.Delete
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.ClearContents
    Selection.Interior.ColorIndex = 2

'/////Copy Task Numbers to Scratch Paper//////
On Error Resume Next
Set Range_Alpha = Application.Worksheets("Estimate").Range("A8:A1000")
Set Range_Bravo = Application.Worksheets("Scratch Paper").Range("A2:A1000")
Set WS = Worksheets("Scratch Paper")
WS.Activate

Worksheets("Scratch Paper").Range("A2").Resize(Range_Alpha.Rows.Count, Range_Alpha.Columns.Count).Cells.Value = Range_Alpha.Cells.Value
Range_Bravo.SpecialCells(xlCellTypeBlanks).Rows.Delete Shift:=xlShiftUp

WS.Range("A2:A1000").Select
    Selection.AutoFilter
        ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:=Array("1", _
        "210", "220", "221", "224", "226", "228", "781", "781A", "781B", "781C", "781D", "782", "910", "912", "914", "920", "922", _
        "924", "926", "928", "930", "999", "X910", "X920", "X922", "X924", "X926", "X928", "X930", _
        "X930.01", "Y210", "Y220", "Y224", "Y226"), Operator:=xlFilterValues

WS.Range("A2:A1000").SpecialCells(xlCellTypeVisible).ClearContents

WS.ShowAllData


'//////Insert Rows//////

LastRow = WS.Cells.Find( _
                        What:="*", _
                        LookIn:=xlFormulas, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row
For i = LastRow To (FirstRow + RowCount) Step -1
    If (i - FirstRow) Mod RowCount = 0 Then WS.Rows(i & ":" & i + RowsToInsert - 1).Insert Shift:=xlDown
Next i

'/////Copy Data to Asset Information Tab/////

Worksheets("Asset Information").Range("A8").Resize(Range_Bravo.Rows.Count, Range_Bravo.Columns.Count).Cells.Value = Range_Bravo.Cells.Value

'//////Inserts formulas and initial cell formating///////

Worksheets("Asset Information").Activate

Set Range_Charlie = Application.Worksheets("Asset Information").Range("A8:A1000")

For Each Cell_Charlie In Range_Charlie
    If IsEmpty(Cell_Charlie) = False Then
        Cell_Charlie.Offset(0, 8).FormulaR1C1 = "=INDEX(Estimate!C[-8]:C[4],MATCH(RC[-8],Estimate!C[-8],0),13)"
        Cell_Charlie.Offset(5, 8).FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
        Cell_Charlie.Offset(5, 8).Font.Bold = True
        Cell_Charlie.Offset(5, 9).FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
        Cell_Charlie.Offset(5, 9).Font.Bold = True
        Cell_Charlie.Offset(5, 10).FormulaR1C1 = "=IF(RC[-2]-RC[-1]=0,""MATCH"",""ERROR"")"
        Cell_Charlie.Offset(0, 11).FormulaR1C1 = "=RC[-2]/Tables!R3C7"
        Cell_Charlie.Offset(1, 11).FormulaR1C1 = "=RC[-2]/Tables!R3C7"
        Cell_Charlie.Offset(2, 11).FormulaR1C1 = "=RC[-2]/Tables!R3C7"
        Cell_Charlie.Offset(3, 11).FormulaR1C1 = "=RC[-2]/Tables!R3C7"
        Cell_Charlie.Offset(4, 11).FormulaR1C1 = "=RC[-2]/Tables!R3C7"

        '/////Insert Validation/////
        Cell_Charlie.Offset(0, 4).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!V3:V58"
        Cell_Charlie.Offset(1, 4).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!V3:V58"
        Cell_Charlie.Offset(2, 4).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!V3:V58"
        Cell_Charlie.Offset(3, 4).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!V3:V58"
        Cell_Charlie.Offset(4, 4).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!V3:V58"
        Cell_Charlie.Offset(0, 3).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!K3:K12"
        Cell_Charlie.Offset(1, 3).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!K3:K12"
        Cell_Charlie.Offset(2, 3).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!K3:K12"
        Cell_Charlie.Offset(3, 3).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!K3:K12"
        Cell_Charlie.Offset(4, 3).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Tables!K3:K12"

        '/////Formula to Reference Table/////
        Cell_Charlie.Offset(0, 5).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[11]:C[16],MATCH(RC[-1],Tables!C[16],0),3),"" "")"
        Cell_Charlie.Offset(1, 5).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[11]:C[16],MATCH(RC[-1],Tables!C[16],0),3),"" "")"
        Cell_Charlie.Offset(2, 5).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[11]:C[16],MATCH(RC[-1],Tables!C[16],0),3),"" "")"
        Cell_Charlie.Offset(3, 5).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[11]:C[16],MATCH(RC[-1],Tables!C[16],0),3),"" "")"
        Cell_Charlie.Offset(4, 5).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[11]:C[16],MATCH(RC[-1],Tables!C[16],0),3),"" "")"
        Cell_Charlie.Offset(0, 7).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[9]:C[15],MATCH(RC[-3],Tables!C[14],0),7),"" "")"
        Cell_Charlie.Offset(1, 7).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[9]:C[15],MATCH(RC[-3],Tables!C[14],0),7),"" "")"
        Cell_Charlie.Offset(2, 7).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[9]:C[15],MATCH(RC[-3],Tables!C[14],0),7),"" "")"
        Cell_Charlie.Offset(3, 7).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[9]:C[15],MATCH(RC[-3],Tables!C[14],0),7),"" "")"
        Cell_Charlie.Offset(4, 7).FormulaR1C1 = "=IFERROR(INDEX(Tables!C[9]:C[15],MATCH(RC[-3],Tables!C[14],0),7),"" "")"

            With Cell_Charlie.Offset(5, 9).Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThick
            End With
            With Cell_Charlie.Offset(5, 9).Borders(xlEdgeTop)

                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin

            End With
            With Cell_Charlie.Offset(5, 8).Borders(xlEdgeBottom)

                .LineStyle = xlDouble
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThick

            End With

            With Cell_Charlie.Offset(5, 8).Borders(xlEdgeTop)

                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin

            End With

            With Range(Cell_Charlie.Offset(5, 15), Cell_Charlie.Offset(5, 0)).Interior
                .ColorIndex = 48
            End With

    End If

Next Cell_Charlie

Set Range_Delta = Application.Worksheets("Asset Information").Range("L8:L1000")

For Each Cell_Delta In Range_Delta
    If IsEmpty(Cell_Delta) = False Then

    Cell_Delta.Offset(0, 1).FormulaR1C1 = "=(RC[-1]*Tables!R4C7)+RC[-3]"

    End If

Next Cell_Delta

'//////Conditional formatting to validate if the task and asset ammounts equal///////

Worksheets("Asset Information").Activate

Range("K8:K1000").Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="MATCH", _
        TextOperator:=xlContains
            Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
                With Selection.FormatConditions(1).Font
                   .ThemeColor = xlThemeColorDark1
                   .TintAndShade = 0
                End With
                With Selection.FormatConditions(1).Interior
                   .PatternColorIndex = xlAutomatic
                   .Color = 5296274
                   .TintAndShade = 0
                End With
                    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="ERROR", _
        TextOperator:=xlContains
            Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
                With Selection.FormatConditions(1).Font
                    .ThemeColor = xlThemeColorDark1
                    .TintAndShade = 0
                End With
                With Selection.FormatConditions(1).Interior
                    .PatternColorIndex = xlAutomatic
                    .Color = 255
                    .TintAndShade = 0
                End With
                    Selection.FormatConditions(1).StopIfTrue = False

'//////Number formatting/////////

ActiveSheet.Range("I:I").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
ActiveSheet.Range("J:J").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
ActiveSheet.Range("M:M").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
ActiveSheet.Range("L:L").NumberFormat = "0.00%"
Worksheets("Scratch Paper").Visible = False
Worksheets("Tables").Visible = False


'//////Re-enable workbook applications/////

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True

'//////Message Box

MsgBox "Insert Asset Description and Asset Cost"

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...