Super slow macro

putzhead

Board Regular
Joined
Nov 24, 2003
Messages
96
Office Version
  1. 2013
Platform
  1. Windows
I hope someone can help....I am a newbie to macros and will be the first to admit that I don't really have a clue as to what I am doing so please don't laugh to loud. I have found various codes from this group to put together what I need and it seems to work fine if I use a file with a lot of data but if I use a file that only has 10-20 rows, the macro takes forever. Can someone take a look and let me know where my problem is? Thanks

What this is suppose to do is to take an EDI report, insert the customer's name, and then place each customer on their own worksheet.


Sub EDI_Macro()

Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Range("B1").Select
ActiveCell.FormulaR1C1 = "Account"
Range("B2").Select
Selection.FormulaArray = _
"=IF(ISERROR(MATCH(RC[-1],'Account Info'!C1,FALSE)),"""",INDEX('Account Info'!C1:C2,MATCH(RC[-1],'Account Info'!C1,FALSE),2))"
Dim r As Long
r = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2").AutoFill Destination:=Range("b2:b" & r)
Columns("B:B").EntireColumn.AutoFit
Range("A1").Select

'Delete blank rows
Dim cl As Range, cl2 As String, OrigCl As String, y As Boolean
Application.ScreenUpdating = False
Do: Set cl = [b2:b3].Find("-", LookIn:=xlValues, LookAt:=xlWhole)
If cl Is Nothing Then Exit Do
cl.EntireRow.Delete
Loop
Set cl = [b2:b500].Find("if", LookIn:=xlFormulas, LookAt:=xlPart)
If Not cl Is Nothing Then
OrigCl = cl.Address
cl2 = cl(0).Address
If cl = vbNullString Then
y = True: cl.EntireRow.Delete
End If
Do
If Not y Then
Set cl = [b2:b500].FindNext(cl)
Else: Set cl = [b2:b500].FindNext(Range(cl2))
End If
If cl Is Nothing Or cl.Address = OrigCl Then Exit Do
If cl.Address <> OrigCl Then
If cl = vbNullString Then
cl2 = cl(0).Address: y = True: cl.EntireRow.Delete
Else: y = False
End If
End If
Loop
Set cl = Nothing
End If
Application.ScreenUpdating = True

'Copy and paste entire sheet
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False

Dim Rng As Range, MyArray() As String, c, i As Integer
Dim CurRng As Range, e As Integer, TmpRng As Range, TmpName As String

'Find unique categories
Set Rng = Range("B1:B" & Range("B500").End(xlUp).Row)
Rng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set Rng = Rng.SpecialCells(xlCellTypeVisible)
ActiveSheet.ShowAllData

'Place unique values into an array
ReDim Preserve MyArray(0)

For Each c In Rng
If Not c = Range("b1").Value Then 'Disregard heading
ReDim Preserve MyArray(UBound(MyArray) + 1)
MyArray(UBound(MyArray)) = c
End If
Next c

'Create Sheets
For i = 1 To UBound(MyArray)
With ActiveWorkbook
.Sheets.Add After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = MyArray(i)
End With
Next i

'Filter range then copy to sheet
Sheets("Sheet1").Activate
Set CurRng = Range("a1:w" & Range("c500").End(xlUp).Row)

For e = 1 To UBound(MyArray)
TmpName = MyArray(e)
CurRng.AutoFilter Field:=2, Criteria1:=TmpName
Set TmpRng = CurRng.SpecialCells(xlCellTypeVisible)
TmpRng.Copy
Worksheets(TmpName).Range("a1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
CurRng.AutoFilter 'turn off autofilter
Next e




End Sub
 
putzhead said:
Nimrod....does the macro create new worksheets or workbooks? i would like them to have their own workbook.....

Phatom....can i modify this so that the workbooks are not automatically saved?

sorry, but i won't be able to test either of these till next year.....i am on vacation till then and i forgot to bring the files home.

happy holidays to everyone!

You can do this, however, each workbook will be Book1, Book2, etc. There would be no way to distinguish each workbook. The other problem is that you will be left with hundreds of open workbooks that you will have to manually change the name, save and close. If this is still the desired result, simply remove these two lines of code:

WkBk.SaveAs FileName:=ThisWorkbook.Path & "\" & ThisCell.Value & ".xls"
WkBk.Close
 
Upvote 0

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

Forum statistics

Threads
1,213,527
Messages
6,114,140
Members
448,551
Latest member
Sienna de Souza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top