我想知道是否有人可以帮助我。
我正在使用下面的代码在找到特定的单元格值时将数据从一张纸复制到另一张。
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'语句的错误感到不满。
我只是想知道某人是否能够看到这个并让我知道我哪里出错了。
答案 0 :(得分：4)
我最终重写了很多代码以使其更有效率，这应该可以实现您正在寻找的东西，而且它应该也能够快速运行：
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
答案 1 :(得分：0)
您的示例数据有点令人困惑，我假设在开销表上您希望开销代码来自任务列。对于增强功能，您希望代码成为项目名称。
如果不正确，请提供更好的样本数据。
试试这段代码：
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