VBA Кодирование конкретных ячеек для конкретных листов

Question

Мне было интересно, может ли кто-нибудь помочь мне.

Я использую приведенный ниже код для копирования данных с одного листа на другой при обнаружении определенных значений ячеек.

Sub Extract() 
    Dim i As Long, j As Long, m As Long 
    Dim strProject As String 
    Dim RDate As Date 
    Dim RVal As Single 
    Dim BlnProjExists As Boolean 
    With Sheets("Enhancements").Range("B3") 
    For i = 1 To .CurrentRegion.Rows.Count - 1 
     For j = 0 To 13 
      .Offset(i, j) = "" 
     Next j 
    Next i 
End With 
With Sheets("AllData").Range("E3") 
    For i = 1 To .CurrentRegion.Rows.Count - 1 
    strProject = .Offset(i, 0) 
    RDate = .Offset(i, 3) 
    RVal = .Offset(i, 4) 
    If InStr(.Offset(i, 0), "Enhancements") > 0 Then 
      strProject = .Offset(i, 0) 
     ElseIf InStr(.Offset(i, 0), "OVH") > 0 And RVal > 0 Then 
      strProject = .Offset(i, -1) 
     Else 
      GoTo NextLoop 
     End If 

     With Sheets("Enhancements").Range("B3") 
      If .CurrentRegion.Rows.Count = 1 Then 
       .Offset(1, 0) = strProject 
       j = 1 
      Else 
       BlnProjExists = False 
       For j = 1 To .CurrentRegion.Rows.Count - 1 
        If .Offset(j, 0) = strProject Then 
         BlnProjExists = True 
         Exit For 
        End If 
       Next j 
       If BlnProjExists = False Then 
.Offset(j, 0) = strProject 
       End If 
      End If 
      Select Case Format(RDate, "mmm yy") 
       Case "Apr 13" 
        m = 1 
       Case "May 13" 
        m = 2 
       Case "Jun 13" 
        m = 3 
       Case "Jul 13" 
        m = 4 
       Case "Aug 13" 
        m = 5 
       Case "Sep 13" 
        m = 6 
       Case "Oct 13" 
        m = 7 
       Case "Nov 13" 
        m = 8 
       Case "Dec 13" 
        m = 9 
       Case "Jan 14" 
        m = 10 
       Case "Feb 14" 
        m = 11 
       Case "Mar 14" 
        m = 12 
      End Select 
      .Offset(j, m) = .Offset(j, m) + RVal 
     End With 
NextLoop: 
    Next i 
End With 
End Sub 

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

Кусок сценария, который мне нужно изменить, как показано ниже:

If InStr(.Offset(i, 0), "Enhancements") > 0 Then 
       strProject = .Offset(i, 0) 
      ElseIf InStr(.Offset(i, 0), "OVH") > 0 And RVal > 0 Then 
       strProject = .Offset(i, -1) 
      Else 
       GoTo NextLoop 
      End If 

      With Sheets("Enhancements").Range("B3") 
       If .CurrentRegion.Rows.Count = 1 Then 
        .Offset(1, 0) = strProject 
        j = 1 
       Else 

В его нынешнем формате, если текстовые значения «Расширения» или «OVH» найдены данные копируются и вставить на лист «Улучшения».

Я хотел бы изменить это, поэтому, если текстовое значение «Улучшения» найдено, информация вставляется на страницу «Улучшения», и если текстовое значение «OVH» найдено, информация вставляется в «Накладные расходы». Остальная часть кода может оставаться такой, какая есть.

Как я уже сказал, я попытался внести изменения, но, похоже, я ошибаюсь в ошибках, связанных с использованием утверждений «If», ElseIf и «Else».

Я просто задавался вопросом, может ли кто-нибудь взглянуть на это, пожалуйста, и дайте мне знать, где я ошибаюсь.

Answer 1

Ваши данные образец немного смущаясь, я предположил, что на листе накладных расходов вы хотите, чтобы код служебных данных был из столбца задачи. Для улучшений вы хотите, чтобы код был именем проекта.

Если это неверно, предоставьте более качественные данные образца.

Попробуйте этот код:

Sub HTH() 
    Dim rLookup As Range, rFound As Range 
    Dim lLastRow As Long, lRow As Long 
    Dim lMonthIndex As Long, lProjectIndex As Long 
    Dim vData As Variant, vMonths As Variant 
    Dim iLoop As Integer 
    Dim vbDict As Object 

    With Worksheets("AllData") 
     Set rLookup = .Range("E3", .Cells(Rows.Count, "E").End(xlUp)) 
     Set rFound = .Range("E3") 
    End With 

    Set vbDict = CreateObject("Scripting.Dictionary") 
    vMonths = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3) 

    For iLoop = 0 To 1 
     lRow = 0: lLastRow = 3 
     vbDict.RemoveAll: ReDim vData(rLookup.Count, 13) 
     Do 
      Set rFound = Worksheets("AllData").Cells.Find(Array("Enhancements", "OVH")(iLoop), _ 
       rFound, , , xlByRows, xlNext, False) 
      If rFound Is Nothing Then Exit Do 
      If rFound.Row <= lLastRow Then Exit Do 
      lMonthIndex = WorksheetFunction.Match(Month(CDate(rFound.Offset(, 4).Value)), vMonths, False) 
      If vbDict.exists(rFound.Offset(, -iLoop).Value) Then 
       lProjectIndex = vbDict.Item(rFound.Value) 
       vData(lProjectIndex, lMonthIndex) = _ 
       vData(lProjectIndex, lMonthIndex) + rFound.Offset(, 4).Value 
      Else 
       vbDict.Add rFound.Offset(, -iLoop).Value, lRow 
       vData(lRow, 0) = rFound.Offset(, -iLoop).Value 
       vData(lRow, lMonthIndex) = rFound.Offset(, 4).Value 
       lRow = lRow + 1 
      End If 
      lLastRow = rFound.Row 
     Loop 
     If iLoop = 0 Then 
      With Worksheets("Enhancements") 
       .Range("B4:O" & Rows.Count).ClearContents 
       .Range("B4").Resize(vbDict.Count + 1, 13).Value = vData 
      End With 
     Else 
      With Worksheets("Overheads") 
       .Range("B4:O" & Rows.Count).ClearContents 
       .Range("B4").Resize(vbDict.Count + 1, 13).Value = vData 
      End With 
     End If 
    Next iLoop 

End Sub 

комментариям версия:

Sub HTH() 
    Dim rLookup As Range, rFound As Range 
    Dim lLastRow As Long, lRow As Long 
    Dim lMonthIndex As Long, lProjectIndex As Long 
    Dim vData As Variant, vMonths As Variant 
    Dim iLoop As Integer 
    Dim vbDict As Object 

    '// Get the projects range to loop through 
    With Worksheets("AllData") 
     Set rLookup = .Range("E3", .Cells(Rows.Count, "E").End(xlUp)) 
     Set rFound = .Range("E3") 
    End With 

    '// Use a latebinded dictionary to store the project names. 
    Set vbDict = CreateObject("Scripting.Dictionary") 
    '// Create an array of the months to get the correct columns. Instead of your select case method 
    vMonths = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3) 

    '// Loop through both search requirements 
    For iLoop = 0 To 1 
     '// Set the counters - lLastRow is used to make sure the loop is not never ending. 
     lRow = 0: lLastRow = 3 
     '// Clear the dictionary and create the projects array. 
     vbDict.RemoveAll: ReDim vData(rLookup.Count, 13) 
     Do 
      '// Search using the criteria requried 
      Set rFound = Worksheets("AllData").Cells.Find(Array("Enhancements", "OVH")(iLoop), _ 
       rFound, , , xlByRows, xlNext, False) 
      '// Make sure something was found and its not a repeat. 
      If rFound Is Nothing Then Exit Do 
      If rFound.Row <= lLastRow Then Exit Do 
      '// Get the correct month column using our months array and the project date. 
      lMonthIndex = WorksheetFunction.Match(Month(CDate(rFound.Offset(, 4).Value)), vMonths, False) 
      '// Check if the project exists. 
      If vbDict.exists(rFound.Offset(, -iLoop).Value) Then 
       '// Yes it exists so add the actuals to the correct project/month. 
       lProjectIndex = vbDict.Item(rFound.Value) 
       vData(lProjectIndex, lMonthIndex) = _ 
       vData(lProjectIndex, lMonthIndex) + rFound.Offset(, 4).Value 
      Else 
       '// No it doesnt exist, create it and then add the actuals to the correct project/month 
       vbDict.Add rFound.Offset(, -iLoop).Value, lRow 
       vData(lRow, 0) = rFound.Offset(, -iLoop).Value 
       vData(lRow, lMonthIndex) = rFound.Offset(, 4).Value 
       '// Increase the project count. 
       lRow = lRow + 1 
      End If 
      '// Set the last row = the last found row to ensure we dont repeat the search. 
      lLastRow = rFound.Row 
     Loop 
     If iLoop = 0 Then 
      '// Clear the enhancements sheet and populate the cells from the array 
      With Worksheets("Enhancements") 
       .Range("B4:O" & Rows.Count).ClearContents 
       .Range("B4").Resize(vbDict.Count + 1, 13).Value = vData 
      End With 
     Else 
      '// Clear the overheads sheet and populate the cells from the array 
      With Worksheets("Overheads") 
       .Range("B4:O" & Rows.Count).ClearContents 
       .Range("B4").Resize(vbDict.Count + 1, 13).Value = vData 
      End With 
     End If 
    Next iLoop 

End Sub 

Answer 2

я в конечном итоге переписывания много кода, чтобы сделать его более эффективным, это должно сделать то, что вы ищете, и он должен работать достаточно быстро, также:

Sub Extract() 

    Dim cllProjects As Collection 
    Dim wsData As Worksheet 
    Dim wsEnha As Worksheet 
    Dim wsOver As Worksheet 
    Dim rngFind As Range 
    Dim rngFound As Range 
    Dim rngProject As Range 
    Dim arrProjects() As Variant 
    Dim varProjectType As Variant 
    Dim ProjectIndex As Long 
    Dim cIndex As Long 
    Dim dRVal As Double 
    Dim dRDate As Double 
    Dim strFirst As String 
    Dim strProjectFirst As String 
    Dim strProject As String 

    Set wsData = Sheets("AllData") 
    Set wsEnha = Sheets("Enhancements") 
    Set wsOver = Sheets("Overheads") 

    wsEnha.Range("B4:O" & Rows.Count).ClearContents 
    wsOver.Range("B4:O" & Rows.Count).ClearContents 

    With wsData.Range("E4", wsData.Cells(Rows.Count, "E").End(xlUp)) 
     If .Row < 4 Then Exit Sub 'No data 
     On Error Resume Next 
     For Each varProjectType In Array("Enhancements", "OVH") 
      Set cllProjects = New Collection 
      ProjectIndex = 0 
      ReDim arrProjects(1 To WorksheetFunction.CountIf(.Cells, "*" & varProjectType & "*"), 1 To 14) 
      Set rngFound = .Find(varProjectType, .Cells(.Cells.Count), xlValues, xlPart) 
      If Not rngFound Is Nothing Then 
       strFirst = rngFound.Address 
       Do 
        strProject = vbNullString 
        dRDate = wsData.Cells(rngFound.Row, "H").Value2 
        dRVal = wsData.Cells(rngFound.Row, "I").Value2 

        If varProjectType = "OVH" And dRVal > 0 Then 
         strProject = wsData.Cells(rngFound.Row, "D").Text 
         Set rngFind = Intersect(.EntireRow, wsData.Columns("D")) 
        ElseIf varProjectType = "Enhancements" Then 
         strProject = wsData.Cells(rngFound.Row, "E").Text 
         Set rngFind = .Cells 
        End If 

        If Len(strProject) > 0 Then 
         cllProjects.Add LCase(strProject), LCase(strProject) 
         If cllProjects.Count > ProjectIndex Then 
          ProjectIndex = cllProjects.Count 
          arrProjects(ProjectIndex, 1) = strProject 
          Set rngProject = Intersect(rngFound.EntireRow, Columns(rngFind.Column)) 
          strProjectFirst = rngProject.Address 
          Do 
           If LCase(rngProject.Text) = LCase(strProject) Then 
            dRDate = wsData.Cells(rngProject.Row, "H").Value2 
            dRVal = wsData.Cells(rngProject.Row, "I").Value2 
            cIndex = Month(dRDate) - 2 + (Year(dRDate) - 2013) * 12 
            arrProjects(ProjectIndex, cIndex) = arrProjects(ProjectIndex, cIndex) + dRVal 
           End If 
           Set rngProject = rngFind.Find(arrProjects(ProjectIndex, 1), rngProject, xlValues, xlPart) 
          Loop While rngProject.Address <> strProjectFirst 
         End If 
        End If 
        Set rngFound = .Find(varProjectType, rngFound, xlValues, xlPart) 
       Loop While rngFound.Address <> strFirst 
      End If 

      If cllProjects.Count > 0 Then 
       Select Case varProjectType 
        Case "Enhancements": wsEnha.Range("B4").Resize(cllProjects.Count, UBound(arrProjects, 2)).Value = arrProjects 
        Case "OVH":    wsOver.Range("B4").Resize(cllProjects.Count, UBound(arrProjects, 2)).Value = arrProjects 
       End Select 
       Set cllProjects = Nothing 
      End If 

     Next varProjectType 
     On Error GoTo 0 
    End With 

    Set cllProjects = Nothing 
    Set wsData = Nothing 
    Set wsEnha = Nothing 
    Set wsOver = Nothing 
    Set rngFound = Nothing 
    Set rngProject = Nothing 
    Erase arrProjects 

End Sub