Well.... there's a couple of things that *I* see...
#1... "Total" is 5 characters, not 4...
so Left(ActiveCell.Value, 4) = "Total" will never be true!!!
Also, you need to learn to run the debugger and 'step through'
your code.
You can then go one line at a time and see what is actually
happening...
I know that using the technique of selecting a cell,
and using the .offset is popular.. but I don't like it.
I'm more of an "array index" kind of guy.. but I can do it...
I cleaned up your code...
try this instead:
Sub Run()
Application.ScreenUpdating = False
Cells(5, 1).Select
Do Until ActiveCell.Value = ""
If Left(ActiveCell.Value, 8) = "Category" Then
cat = Mid(ActiveCell.Value, 12, Len(ActiveCell.Value))
ElseIf Left(ActiveCell.Value, 4) = "Type" Then
tp = Mid(ActiveCell.Value, 8, Len(ActiveCell.Value))
tot = ActiveCell.Offset(0, 1).Value
Call paste
End If
ActiveCell.Offset(1, 0).Select
Loop
Cells(5, 1).Select
End Sub
I'd probably lose the "paste" sub and use something like:
Sub Run2()
Dim x, outrow, outcol, cat
outrow = Application.WorksheetFunction.CountA(Range("E1:E65000"))
outcol = 5
For x = 5 To 1000
If (Cells(x, 1) & "X" = "X") Then Exit For
If (UCase(Left(Cells(x, 1), 8)) = UCase("Category")) Then
cat = Mid(Cells(x, 1), 12, Len(Cells(x, 1)))
ElseIf (UCase(Left(Cells(x, 1), 4)) = UCase("Type")) Then
outrow = outrow + 1
Cells(outrow, outcol) = cat & " : " & Mid(Cells(x, 1), 8,
Len(Cells(x, 1)))
Cells(outrow, outcol + 1) = Cells(x, 2)
End If
Next x
End Sub
(it gets rid of the "selects")
hope this helps...
Paul
________________________________
From: Jack <j...@jackcwood.co.uk>
To: MS EXCEL AND VBA MACROS <excel-macros@googlegroups.com>
Sent: Thursday, June 11, 2009 2:50:38 PM
Subject: $$Excel-Macros$$ Loop Nightmare !!
I need some help editing my loop
here is the file
Category : AU Queries
Type : AU Disputes 10
Type : Change of AU 20
Type : Change of Name 30
Type : New AU 40
Type : Other 50
Type : Reissue 60
Total for Category : AU Queries 210
Category : AU Misc
Type : AU Disputes 10
Type : Change of AU 20
Type : Change of Name 30
Type : New AU 40
Type : Other 50
Type : Reissue 60
Total for Category : AU Queries 210
and here is the result needed
AU Queries : AU Disputes 10
AU Queries : Change of AU 20
AU Queries : Change of Name 30
AU Queries : New AU 40
AU Queries : Other 50
AU Queries : Reissue 60
AU Misc : AU Disputes 10
AU Misc : Change of AU 20
AU Misc : Change of Name 30
AU Misc : New AU 40
AU Misc : Other 50
AU Misc : Reissue 60
my code below gives the result AU Misc:Reissue 10 can any one help !!
Dim tot As Integer
Dim cat, tp As String
Sub Run()
Application.ScreenUpdating = False
i = 1
Cells(5, 1).Select
Do Until Left(ActiveCell.Value, 4) = "Total" Or ActiveCell.Value = ""
If Left(ActiveCell.Value, 8) = "Category" Then
cat = Mid(ActiveCell.Value, 12, Len(ActiveCell.Value))
End If
If Left(ActiveCell.Value, 4) = "Type" Then
tp = Mid(ActiveCell.Value, 8, Len(ActiveCell.Value))
If i = 1 Then
tot = ActiveCell.Offset(0, 1).Value
i = 0
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select
If i = 0 Then
Call paste
End If
i = 1
Cells(5, 1).Select
End Sub
Sub paste()
Range("e65000").End(xlUp).Offset(1, 0).Value = cat & ":" & tp
Range("f65000").End(xlUp).Offset(1, 0).Value = tot
End Sub
--~--~---------~--~----~------------~-------~--~----~
-------------------------------------------------------------------------------------
Some important links for excel users:
1. Excel and VBA Tutorials(Video and Text), Free add-ins downloads at
http://www.excelitems.com
2. Excel tutorials at http://www.excel-macros.blogspot.com
3. Learn VBA Macros at http://www.vbamacros.blogspot.com
4. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
If you find any spam message in the group, please send an email to:
Ayush Jain @ jainayus...@gmail.com or
Ashish Jain @ 26may.1...@gmail.com
-------------------------------------------------------------------------------------
-~----------~----~----~----~------~----~------~--~---
