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
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
I think it would be easier for one of us to write a macro from scratch for you instead of reading through the macro you have posted. Can you provide step-by-step instructions of what you would like to do? Also include how/when you would like the macro to execute (have macro run every time you enter data into a cell, macro to be executed manually, etc.)
 
Upvote 0
Please provide a some examples of what the data looks like before and after. I've got to agree with phantom... I would prefer to just write some new code then pick thru all this code :wink:
 
Upvote 0
I have a report that has a customer number in column A, and other sales information in columns B thru K. The customer numbers are not always together as a group and there are also some blank rows every so often (no pattern). The end result is to try to put the each customer on their own workbook.

My thought process was to do a Lookup to add the customers name (column B), then sort, delete the blanks, separate by customer, and kick them out to their own workbook.

Does this make sense?
 
Upvote 0
Sorry for to mention, this report will never go down past row 500
 
Upvote 0
This procedure will make a new sheet for each customer number found in ColumnA of the Activesheet. If there are serveral rows of info on each customer number one sheet will be produced for the information. EG one sheet per customer.
1) make sure cust nums in column A ( in any order)
2) make sure this is the active sheet.

Public Sub EachCustomerNewSheet()
With ActiveSheet
For Each CustNum In Columns("A:A").SpecialCells(xlCellTypeConstants, 3)
SheetExist ("Cust-" & CustNum)
NxRow = Sheets("Cust-" & CustNum).Cells(65536, 1).End(xlUp).Row + 1
Sheets("Cust-" & CustNum).Range("A" & NxRow & ":K" & NxRow).Value = .Range("A" & CustNum.Row & ":K" & CustNum.Row).Value
Next CustNum
End With
End Sub
Function SheetExist(ShName As String) As Boolean
On Error GoTo NoSheet
Sht = Sheets(ShName).Visible
Exit Function
NoSheet:
Sheets.Add
ActiveSheet.Name = ShName
End Function
 
Upvote 0
Here you go:

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> CreateWorkbooks()

<SPAN style="color:#00007F">Dim</SPAN> ThisCell <SPAN style="color:#00007F">As</SPAN> Range
<SPAN style="color:#00007F">Dim</SPAN> WkBk <SPAN style="color:#00007F">As</SPAN> Workbook
<SPAN style="color:#00007F">Dim</SPAN> Sh <SPAN style="color:#00007F">As</SPAN> Worksheet

    <SPAN style="color:#00007F">Set</SPAN> Sh = ActiveSheet
    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> ThisCell <SPAN style="color:#00007F">In</SPAN> Range("A1:A" & Sh.Range("A65536").End(xlUp).Row)
        <SPAN style="color:#00007F">If</SPAN> ThisCell.Value <> "" <SPAN style="color:#00007F">Then</SPAN>
            <SPAN style="color:#00007F">Set</SPAN> WkBk = Application.Workbooks.Add
            Sh.Rows.EntireRow(ThisCell.Row).Copy WkBk.Sheets(1).Range("A1")
            WkBk.SaveAs FileName:=ThisWorkbook.Path & "\" & ThisCell.Value & ".xls"
            WkBk.<SPAN style="color:#00007F">Close</SPAN>
        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
    <SPAN style="color:#00007F">Next</SPAN> ThisCell

<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>
 
Upvote 0
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!
 
Upvote 0
This one moves each Cust worksheet to it's own Workbook ... OK ?

Public Sub EachCustomerNewSheet()
With ActiveSheet
For Each CustNum In Columns("A:A").SpecialCells(xlCellTypeConstants, 3)
SheetExist ("Cust-" & CustNum)
NxRow = Sheets("Cust-" & CustNum).Cells(65536, 1).End(xlUp).Row + 1
Sheets("Cust-" & CustNum).Range("A" & NxRow & ":K" & NxRow).Value = .Range("A" & CustNum.Row & ":K" & CustNum.Row).Value
Next CustNum
End With
For Each Sh In ThisWorkbook.Worksheets
If Left(Sh.Name, 4) = "Cust" Then
ThisWorkbook.Activate
Sheets(Sh.Name).Move
End If
Next Sh
End Sub
Function SheetExist(ShName As String) As Boolean
On Error GoTo NoSheet
Sht = Sheets(ShName).Visible
Exit Function
NoSheet:
Sheets.Add
ActiveSheet.Name = ShName
End Function
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,255
Members
448,556
Latest member
peterhess2002

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