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
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