Sub TimeCodeToTotals()
Dim rE As Range, rTC As Range, rT As Range, c As Range, i As Long
Set rE = Range("E10", Range("E" & Rows.Count).End(xlUp))
'tFindAll, 'http://www.tushar-mehta.com/publish_train/xl_vba_cases/1001%20range.find%20and%20findall.shtml
Set rTC = tFindAll("Time Code", rE(1), LookAt:=xlWhole)
Set rT = tFindAll("Totals", rE(rE.Cells.Count), LookAt:=xlWhole)
If rTC.Cells.Count <> rT.Cells.Count Then
MsgBox "Number of cells in column E for Time Code and Totals is not equal.", vbCritical, "Macro Ending"
Exit Sub
End If
For i = 1 To rTC.Cells.Count
Cells(NthCell(rT, i).Row, "B").Value = Cells(NthCell(rTC, i).Row, "B").Value
Next i
End Sub
'Mike Erickson, http://www.mrexcel.com/forum/excel-questions/559858-how-access-nth-cell-non-contiguous-range.html
'MsgBox NthCell(Range("A1, A3"), 2).Offset(, 1).Value 'Shows value of B3.
Function NthCell(someRange As Range, cellSought As Long) As Range
Dim cCount As Long
Dim oneArea As Range
For Each oneArea In someRange.Areas
If oneArea.Cells.Count < cellSought - cCount Then
cCount = cCount + oneArea.Cells.Count
Else
Set NthCell = oneArea.Item(cellSought - cCount)
Exit Function
End If
Next oneArea
End Function
'http://www.tushar-mehta.com/publish_train/xl_vba_cases/1001%20range.find%20and%20findall.shtml
'Renamed FindAll to tFindAll. Chip Pearson has a FindAll as well.
Function tFindAll(What, Optional SearchWhat As Variant, _
Optional LookIn, _
Optional LookAt, _
Optional SearchOrder, _
Optional SearchDirection As XlSearchDirection = xlNext, _
Optional MatchCase As Boolean = False, _
Optional MatchByte, _
Optional SearchFormat) As Range
'LookIn can be xlValues or xlFormulas, _
LookAt can be xlWhole or xlPart, _
SearchOrder can be xlByRows or xlByColumns, _
SearchDirection can be xlNext, xlPrevious, _
MatchCase, MatchByte, and SearchFormat can be True or False. _
Before using SearchFormat = True, specify the appropriate settings _
for the Application.FindFormat object, e.g., _
Application.FindFormat.NumberFormat = "General;-General;""-"""
Dim aRng As Range
If IsMissing(SearchWhat) Then
On Error Resume Next
Set aRng = ActiveSheet.UsedRange
On Error GoTo 0
ElseIf TypeOf SearchWhat Is Range Then
If SearchWhat.Cells.Count = 1 Then
Set aRng = SearchWhat.Parent.UsedRange
Else
Set aRng = SearchWhat
End If
ElseIf TypeOf SearchWhat Is Worksheet Then
Set aRng = SearchWhat.UsedRange
Else
Exit Function '*****
End If
If aRng Is Nothing Then Exit Function '*****
Dim FirstCell As Range, CurrCell As Range
With aRng.Areas(aRng.Areas.Count)
Set FirstCell = .Cells(.Cells.Count)
'This little 'dance' ensures we get the first matching _
cell in the range first
End With
Set FirstCell = aRng.Find(What:=What, after:=FirstCell, _
LookIn:=LookIn, LookAt:=LookAt, _
SearchDirection:=SearchDirection, MatchCase:=MatchCase, _
MatchByte:=MatchByte, SearchFormat:=SearchFormat)
If FirstCell Is Nothing Then Exit Function '*****
Set CurrCell = FirstCell
Set tFindAll = CurrCell
Do
Set tFindAll = Application.Union(tFindAll, CurrCell)
'Setting FindAll at the top of the loop ensures _
the result is arranged in the same sequence as _
the matching cells; the duplicate assignment of _
the first matching cell to FindAll being a small _
price to pay for the ordered result
Set CurrCell = aRng.Find(What:=What, after:=CurrCell, _
LookIn:=LookIn, LookAt:=LookAt, _
SearchDirection:=SearchDirection, MatchCase:=MatchCase, _
MatchByte:=MatchByte, SearchFormat:=SearchFormat)
'FindNext is not reliable because it ignores the FindFormat settings
Loop Until CurrCell.Address = FirstCell.Address
End Function
Reply With Quote
