-
Dec 31st, 2013, 09:39 AM
#1
Thread Starter
New Member
Macro Running Slow (Loop)
HI Everyone,
I am currently using a macro to gather data from multiple files , it has allot of variable conditions and it needs to keep looping because sometimes the number of files can be upto 5000 or even more at the time.
After a While of running the Macro it goes extremely slow like spending more than 10 mins per file which if I do manually would take me 1 min max, I have posed the Code below (its long) hopefully someone can assist me with this.
Code:
Sub Get_Data()
'
Dim stPath As String
Dim stFile As String
Dim stNewPath As String
Dim StBN As String
Dim StPN As String
Dim StAd1 As String
Dim StAd2 As String
Dim StAd3 As String
Dim StTB As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("Main").Activate
Sheets("Data").Activate
Cells.Select
Selection.ClearContents
Range("A1").Select
ActiveCell.FormulaR1C1 = "Buisness Name"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Phone Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Address Line 1"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Address Line 2"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Address Line 3"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Type of Buisness"
Range("A2").Select
ActiveCell.FormulaR1C1 = "temp"
Range("B2").Select
ActiveCell.FormulaR1C1 = "temp"
Range("C2").Select
ActiveCell.FormulaR1C1 = "temp"
Range("D2").Select
ActiveCell.FormulaR1C1 = "temp"
Range("E2").Select
ActiveCell.FormulaR1C1 = "temp"
Range("F2").Select
ActiveCell.FormulaR1C1 = "temp"
stPath = Sheets("Main").Range("F22").Value
stFile = Dir(stPath & "\*.htm*") '
Do Until stFile = ""
Workbooks.Open stPath & "\" & stFile, ReadOnly:=True
Windows(stFile).Activate
Cells.Find(What:="Within 4 blocks", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select
If IsEmpty(Selection.Value) Then
ActiveCell.Offset(-1, 0).Select
GoTo Label1
Else
On Error GoTo ErrHandler1:
Cells.Find(What:="Paid", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
GoTo Label1:
End If
Label2:
On Error GoTo 0
On Error GoTo ErrHandler2:
Cells.Find(What:="Validated", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Label1:
On Error GoTo 0
Do
ActiveCell.Offset(5, 0).Select
If IsEmpty(Selection.Value) Then
ActiveCell.Offset(2, 0).Select
If IsEmpty(Selection.Value) Then
ActiveCell.Offset(1, 0).Select
If IsEmpty(Selection.Value) Then
ActiveCell.Offset(1, 0).Select
Else
End If
Else
End If
StBN = Selection.Value
ActiveCell.Offset(1, 0).Select
If IsEmpty(Selection.Value) Then
ActiveCell.Offset(1, 0).Select
If IsEmpty(Selection.Value) Then
ActiveCell.Offset(15, 0).Select
If IsEmpty(Selection.Value) Then
StTB = "No Buissness Type"
Else
StTB = Selection.Value
End If
ActiveCell.Offset(2, 0).Select
If Selection.Value Like "Opened*" Then
ActiveCell.Offset(1, 0).Select
ElseIf Selection.Value Like "$*" Then
ActiveCell.Offset(1, 0).Select
End If
StAd1 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd2 = "No Address Line 2"
StAd3 = StAd1
StAd1 = "No Address Line 1"
StPN = Selection.Value
Else
StAd2 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd3 = StAd2
StAd2 = "No Address Line2"
StPN = Selection.Value
Else
StAd3 = Selection.Value
ActiveCell.Offset(1, 0).Select
StPN = Selection.Value
End If
End If
Else
StTB = "No Type of Buisness"
If Selection.Value Like "Opened*" Then
ActiveCell.Offset(1, 0).Select
ElseIf Selection.Value Like "$*" Then
ActiveCell.Offset(1, 0).Select
End If
StAd1 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd3 = StAd1
StAd2 = "No Address Line 2"
StAd1 = "No Address Line 1"
StPN = Selection.Value
Else
StAd2 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd3 = StAd2
StAd2 = "No Address Line 2"
StPN = Selection.Value
Else
StAd3 = Selection.Value
ActiveCell.Offset(1, 0).Select
StPN = Selection.Value
End If
End If
End If
Else
StTB = Selection.Value
ActiveCell.Offset(2, 0).Select
If Selection.Value Like "Opened*" Then
ActiveCell.Offset(1, 0).Select
ElseIf Selection.Value Like "$*" Then
ActiveCell.Offset(1, 0).Select
End If
StAd1 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd2 = "No Address Line 2"
StAd3 = StAd1
StAd1 = "No Address Line1"
StPN = Selection.Value
Else
StAd2 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd3 = StAd2
StAd2 = "No Address Line 2"
StPN = Selection.Value
Else
StAd3 = Selection.Value
ActiveCell.Offset(1, 0).Select
StPN = Selection.Value
End If
End If
End If
ElseIf IsNumeric(Selection.Value) Then
Exit Do
ElseIf Selection.Value Like "Page*" Then
Exit Do
Else
StBN = Selection.Value
ActiveCell.Offset(1, 0).Select
If IsEmpty(Selection.Value) Then
ActiveCell.Offset(1, 0).Select
If IsEmpty(Selection.Value) Then
ActiveCell.Offset(15, 0).Select
If IsEmpty(Selection.Value) Then
StTB = "No Buissness Type"
Else
StTB = Selection.Value
End If
ActiveCell.Offset(2, 0).Select
If Selection.Value Like "Opened*" Then
ActiveCell.Offset(1, 0).Select
ElseIf Selection.Value Like "$*" Then
ActiveCell.Offset(1, 0).Select
End If
StAd1 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd2 = "No Address Line 2"
StAd3 = StAd1
StAd1 = "No Address Line1"
StPN = Selection.Value
Else
StAd2 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd3 = StAd2
StAd2 = "No Address Line 2"
StPN = Selection.Value
Else
StAd3 = Selection.Value
ActiveCell.Offset(1, 0).Select
StPN = Selection.Value
End If
End If
Else
StTB = "No Type of Buisness"
If Selection.Value Like "Opened*" Then
ActiveCell.Offset(1, 0).Select
ElseIf Selection.Value Like "$*" Then
ActiveCell.Offset(1, 0).Select
End If
StAd1 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd2 = "No Address Line 2"
StAd3 = StAd1
StAd1 = " No Address Line1"
StPN = Selection.Value
Else
StAd2 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd3 = StAd2
StAd2 = "No Address Line 2"
StPN = Selection.Value
Else
StAd3 = Selection.Value
ActiveCell.Offset(1, 0).Select
StPN = Selection.Value
End If
End If
End If
Else
StTB = Selection.Value
ActiveCell.Offset(2, 0).Select
If Selection.Value Like "Opened*" Then
ActiveCell.Offset(1, 0).Select
ElseIf Selection.Value Like "$*" Then
ActiveCell.Offset(1, 0).Select
End If
StAd1 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd2 = "No Address Line 2"
StAd3 = StAd1
StAd1 = "No Address Line 1"
StPN = Selection.Value
Else
StAd2 = Selection.Value
ActiveCell.Offset(1, 0).Select
If Selection.Value Like "Phone*" Then
StAd3 = StAd2
StAd2 = "No Address Line 2"
StPN = Selection.Value
Else
StAd3 = Selection.Value
ActiveCell.Offset(1, 0).Select
StPN = Selection.Value
End If
End If
End If
End If
Windows("Lead Extractor US (Yelp) V2.0.xlsb").Activate
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.Value = StBN
Range("B1").End(xlDown).Offset(1, 0).Select
Selection.Value = StPN
Range("C1").End(xlDown).Offset(1, 0).Select
Selection.Value = StAd1
Range("D1").End(xlDown).Offset(1, 0).Select
Selection.Value = StAd2
Range("E1").End(xlDown).Offset(1, 0).Select
Selection.Value = StAd3
Range("F1").End(xlDown).Offset(1, 0).Select
Selection.Value = StTB
Windows(stFile).Activate
Loop
Label3:
On Error GoTo 0
Windows(stFile).Activate
ActiveWorkbook.Close False
Windows("Lead Extractor US (Yelp) V2.0.xlsb").Activate
stFile = Dir()
Loop
Range("A2:F2").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Main").Activate
Range("F12").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
ErrHandler1:
Resume Label2:
ErrHandler2:
Resume Label3:
End Sub
-
Dec 31st, 2013, 09:50 PM
#2
Re: Macro Running Slow (Loop)
change all reference to activecell to a fully qualified range. avoid selecting or activating anything
exmple
Sheets("Main").Activate
Sheets("Data").Activate
Cells.Select
Selection.ClearContents
Range("A1").Select
ActiveCell.FormulaR1C1 = "Buisness Name"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Phone Number"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Address Line 1"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Address Line 2"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Address Line 3"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Type of Buisness"
to
Code:
with sheets("Data")
.usedrange.clearcontents
.Range("A1").FormulaR1C1 = "Buisness Name"
.Range("B1").FormulaR1C1 = "Phone Number"
.Range("C1").FormulaR1C1 = "Address Line 1"
.Range("D1").FormulaR1C1 = "Address Line 2"
.Range("E1").FormulaR1C1 = "Address Line 3"
.Range("F1").FormulaR1C1 = "Type of Buisness"
end with
as you are working with multiple sheets, it may be better to set worksheet objects to work with
are all the files closing, before opening the next?
keep a count in your error handlers to see how much they are called
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Jan 7th, 2014, 09:57 AM
#3
Thread Starter
New Member
Re: Macro Running Slow (Loop)
Originally Posted by westconn1
change all reference to activecell to a fully qualified range. avoid selecting or activating anything
exmple
to
Code:
with sheets("Data")
.usedrange.clearcontents
.Range("A1").FormulaR1C1 = "Buisness Name"
.Range("B1").FormulaR1C1 = "Phone Number"
.Range("C1").FormulaR1C1 = "Address Line 1"
.Range("D1").FormulaR1C1 = "Address Line 2"
.Range("E1").FormulaR1C1 = "Address Line 3"
.Range("F1").FormulaR1C1 = "Type of Buisness"
end with
as you are working with multiple sheets, it may be better to set worksheet objects to work with
are all the files closing, before opening the next?
keep a count in your error handlers to see how much they are called
The error Handlers rarley gets called, the files are bieng closed before opening the new ones and for activating cells unfortunetly i have to move allot to gather the data and there are allot of conditions so I have to keep moving using
Code:
activecell.offset(x,x).activate
as for setting worksheet objects I am not sure what you mean
-
Jan 7th, 2014, 11:36 AM
#4
Re: Macro Running Slow (Loop)
You don't need to "move" to gather the data, which is part of what Pete is saying.
A "Find" can return the range in which the text is found, rather than activating the cell. Once you know where the text is found, you can get value from a cell offset from that cell.
-
Jan 7th, 2014, 11:56 AM
#5
Thread Starter
New Member
Re: Macro Running Slow (Loop)
Originally Posted by vbfbryce
You don't need to "move" to gather the data, which is part of what Pete is saying.
A "Find" can return the range in which the text is found, rather than activating the cell. Once you know where the text is found, you can get value from a cell offset from that cell.
I am sorry , I know im acting kinda Dumb ( havent slept properly for a while ) but I am not sure what you mean , can you write an example just for me to get a better Picture?
because I keep going back to the same sheet get the data from it in strings and the place the value of the strings in another excel sheet, the issue is the data is not in a specific cell, its not constant thats why I have allot of if conditions
-
Jan 7th, 2014, 01:16 PM
#6
Re: Macro Running Slow (Loop)
No problem, will post a quick example in a few minutes
-
Jan 7th, 2014, 02:02 PM
#7
Re: Macro Running Slow (Loop)
A quick example of opening files, checking your conditions and grabbing data without activating and selecting:
Code:
Sub openFiles()
Dim wb As Workbook
Dim ws As Worksheet
Dim stPath As String
Dim stFile As String
Dim StBN As String
Dim StPN As String
Dim StAd1 As String
Dim StAd2 As String
Dim StAd3 As String
Dim StTB As String
Dim rngFind As Range 'the cell (range) where "Within 4 blocks" is found, ie.
Dim rngCurrent As Range
Dim rngNew As Range
stPath = "c:\users\...\documents\vb\logan" 'change to yours
stFile = Dir(stPath & "\*.htm*")
Do Until stFile = ""
Set wb = Workbooks.Open(stPath & "\" & stFile, ReadOnly:=True)
Set ws = wb.Worksheets(1) 'not sure about this...
Set rngFind = ws.Cells.Find(What:="Within 4 blocks", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If IsEmpty(rngFind.Offset(1, 0)) Then
rngCurrent = rngFind.Offset(-1, 0)
Else
rngCurrent = rngFind.Offset(1, 0)
End If
GoTo label1
Loop
label1:
With rngCurrent
If Not IsEmpty(.Offset(5, 0)) Then
StBN = .Offset(5, 0).Value
ElseIf Not IsEmpty(.Offset(7, 0)) Then
StBN = .Offset(7, 0).Value
ElseIf Not IsEmpty(.Offset(8, 0)) Then
StBN = .Offset(8, 0).Value
ElseIf Not IsEmpty(.Offset(9, 0)) Then
StBN = .Offset(9, 0).Value
Else
StBN = "NO VALUE?"
End If
End With
End Sub
-
Jan 8th, 2014, 04:28 AM
#8
Re: Macro Running Slow (Loop)
in most cases, the only good reason to activate a sheet or a cell, is to present it to the user at the end of the macro
you can loop through all the cells you want and read their data, without selecting, just use a fully qualified range
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|