Thread: Loop Error

hello everyone,

I wanted to thank everyone ahead of time for help with this one as I have been racking my brain trying to get this done.

What I am trying to do is basically copy and paste certain cells in certain rows to a worksheet where it will be placed in defined areas on that worksheet. It will then copy that worksheet and do the same thing to the newly created worksheet. Currently, the code I created is in a loop and stops with an error 1004 in Excel 2003. However, when I have used the same macro in excel 2007 it works fine but really slow when the number of sheets created reaches about 200 or so. I have copied my code in here for you to review and maybe someone can help me out with it. Thanks again.

Code:

Sub CREAT()

Dim WS As Worksheet, WB As Workbook
    Set WB = ActiveWorkbook
    Set WS = WB.Sheets("Auto ID card")


Application.ScreenUpdating = False
 Sheets("Main").Select
 Range("b14").Select
 Selection.Copy
 Worksheets(Worksheets.Count).Activate
Range("b11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Main").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Worksheets(Worksheets.Count).Activate
ActiveCell.Offset(0, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Main").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Worksheets(Worksheets.Count).Activate
ActiveCell.Offset(0, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Main").Select
ActiveCell.Offset(0, 2).Select
Selection.Copy
Worksheets(Worksheets.Count).Activate
ActiveCell.Offset(0, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
WS.Copy After:=Sheets(WB.Sheets.Count)
Application.CutCopyMode = False
  
 Do
Sheets("Main").Select
ActiveCell.Offset(1, -4).Select
Selection.Copy
Worksheets(Worksheets.Count).Activate
Range("b11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Main").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Worksheets(Worksheets.Count).Activate
Range("d11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Main").Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Worksheets(Worksheets.Count).Activate
Range("f11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Sheets("Main").Select
ActiveCell.Offset(0, 2).Select
Selection.Copy
Worksheets(Worksheets.Count).Activate
Range("h11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
WS.Copy After:=Sheets(WB.Sheets.Count)
Sheets("Main").Select
Application.CutCopyMode = False

Loop Until IsEmpty(ActiveCell.Offset(1, 0))

Worksheets(Worksheets.Count).Activate
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True

Sheets("Main").Select
Application.CutCopyMode = True

Application.ScreenUpdating = True




End Sub