VBA将特定单元格复制到特定表单
我想知道是否有人可以帮助我。
我使用下面的代码将数据从一张表复制到另一张特定的单元格值被发现。
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
在当前格式下，如果find“增强”或“OVH”的文本值，数据将被复制并粘贴到“增强”页面。
我想改变它，所以如果发现文本值“增强”，信息被粘贴到“增强”页面，如果find“OVH”的文本值，信息被粘贴到“开销”表。 其余的代码可以保持原样。
正如我所说，我已经试图做出这些改变，但是我似乎对“If”，“ElseIf”和“Else”这些陈述的使用有误。
我只是想知道是否有人可以看看这个请让我知道我要去哪里错了。
您的示例数据有点令人困惑，我推测在开销表上您希望开销代码来自任务列。 为了增强你想要的代码是项目名称。
如果这是不正确的，请提供更好的样本数据。
试试这个代码：
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
我最终重写了很多你的代码，使它更有效率，这应该完成你正在寻找的东西，它也应该运行得相当快：
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