vba - 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 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

Answer 2

您的示例数据有点令人困惑，我假设在间接费用表上您希望间接费用代码来自任务列。对于您希望代码成为项目名称的增强功能。

如果不正确，请提供更好的样本数据。

试试这个代码：

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