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