PDA

View Full Version : [SOLVED] Run-Time Error "1004" LOOPS!



aimatarv
05-04-2016, 01:46 AM
16078

I need some help with this guys and gals.

(I hope you can see the image properly)
I need the cell highlighted in green to be copied into the yellow cell and then the contents of the green cell be cleared.
The colors are ONLY for visual aid.

The main thing is it needs to do this for all associates listed on the sheet (there are many associates and not just the two listed in the image). so cell B21 should be the same value as B15 and then b15.

I approached this using a few key terms on the sheet as you will see in my code below:



Sub moveWFMID()

Dim y As Integer
Dim f As Integer

f = 0
y = 0

Do Until y = 24
If (Cells(y + 1, "E").Value) = "Time Code" Then
MsgBox ("no")

If (Cells(f + 0, "E").Value) = "Totals" Then
Cells(y + 1, "B").Value = Cells(f + 0, "B")
'MsgBox (f - 1)
Else
f = f + 1
End If

Else
End If
y = y + 1
Loop

End Sub

16080


My loop might be lacking logic, or there is something that i am doing wrong that keeps returning an error. Any thoughts?

I have attached my file. the code is specifically located in module 2.

SamT
05-04-2016, 06:32 AM
That would probably work if f and y = 10 at the start, then set f=y+1 in the loop.

This will be faster.

Sub SamT()
Dim Y As Range
Dim F As Range
Dim LR As Long

'Get last used Row number
LR = Cells(Rows.Count, "E").End(xlUp).Row

'Set starting point
Set F = Range("B10")
'Alternative: Set F = Range("A1").End(xlDown).Offset(,1)

Do While F <>""
'Set next Totals Row
Set Y = F.End(xlDown).Offset(-1)

'Handle last Totals
If Y.Row > LR Then Set Y = Cells(LR, "B")

Y = F

'Next associate
Set F = Y.Offset(1)

'Alternative to handle empty Rows between associates
'If Y.Offset(1) <> "" Then
'set F = Y.Offset(1)
'Else
'Set F = Y.End(xlDown)
'end IF

Loop

End Sub

NB: Always declare Row number variables as Long

Paul_Hossler
05-04-2016, 09:34 AM
Option Explicit
Sub FlowDown()
Dim rStart As Range

Set rStart = Worksheets("FlashPR Report").Range("B10")

Application.ScreenUpdating = False

Do While rStart.Value <> "Theatre Totals"
Application.StatusBar = rStart.Address

rStart.Copy
rStart.End(xlDown).Offset(-1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues
rStart.ClearContents
Set rStart = Selection.Offset(1, 0)

Loop

Application.StatusBar = False
Application.ScreenUpdating = True

End Sub

Kenneth Hobs
05-04-2016, 01:17 PM
When updating cells, some speed can be added by use of methods that Paul and Mark noted in Application settings. See my speedup routines for my modular methods. http://vbaexpress.com/kb/getarticle.php?kb_id=1035

Paul, your routine went into an infinite loop or stuck at the last rows cell.

Mark, your routine did not change the last pair set. I did not check much else.

My method here is not the most efficient but Find routines can be good. I could speed it up a bit using my speedup code and a different find range value by index method (NthCell). For your data, it seemed to be fast enough. There are several FindAll routines out there. The assumption in my routine is that there are equal number of Time Codes vs. Totals. This allows for 1-1 matched sets.

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

Paul_Hossler
05-04-2016, 03:57 PM
@Ken -- not really

If you look at the OP's file, there are what I took to be reminets of previous trys: 1288803 starting in row 44

16088

If you delete the 100's of those my macro will work


Now it can only be run one time since it relies on the cell above the .End() being the destination, but that wasn't in the requirements spec :devil2:

aimatarv
05-05-2016, 05:27 AM
This worked. Unfortunately the other codes provided by the other users did not work. It would freeze excel.

I unfortunately could not figure out how your logic worked with the code as I was trying to then remove the the associate number that WAS copied within the code you provided.

So i created a new sub. here are the contents of the sub


Dim j As Long
Dim o As Long


o = Cells(Rows.Count, "E").End(xlUp).Row
j = 8

Do Until j = o


If Cells(j + 0, "E").Value = "Time Code" Then




Cells(j + 0, "B").Value = "___"

End If
j = j + 1

Loop




thank you to everyone who assisted in this!