Run time error 1004 VBA Assistance

[Human_doing]

Hi all,

Can anyone please assist with rectifying the 'Run time error 1004' I get when running this VBA. I have a very basic understanding of what causes this but it but can't figure out the exact coding issue.

The purpose of the macro is to allow the user to select a workbook from which sheet 1 is copied to an all-new workbook (first part of code), then the second part of the code copies cells from the range on the newly created sheet 1 to different worksheets in the workbook. The second part of the code works when I run it independently so I'm not sure what the issue is when run altogether?

Any help much appreciated,

Thanks

Sub TestIt()
NewFN = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Select the file with raw data for the report")
If NewFN = False Then
' They pressed Cancel
MsgBox "Stopping because you did not select a file"
Exit Sub
Else
Workbooks.Open Filename:=NewFN
End If
Cells.Select
Selection.Copy
Workbooks.Add
Range("a1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
 
 
 
Dim lastrow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With ActiveSheet
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(2, 1), Cells(lastrow, LastCol)).Sort Key1:=Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
iStart = 2
For i = 2 To lastrow
If .Range("A" & i).Value <> .Range("A" & i + 1).Value Then
iEnd = i
Sheets.Add After:=Sheets(Sheets.Count)
Set ws = ActiveSheet
On Error Resume Next
ws.Name = .Range("A" & iStart).Value
On Error GoTo 0
ws.Range(Cells(1, 1), Cells(1, LastCol)).Value = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
With ws.Rows(1)
.HorizontalAlignment = xlCenter
With .Font
.ColorIndex = 5
.Bold = True
End With
End With
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
 
 
 
End Sub

 

[Sektor]

Wrap your code in "[ CODE ][ /CODE]" tags.

 

[syntaxed]

Maybe:

.Range(.Cells(2, 1), .Cells(lastrow, LastCol)).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

 

[Human_doing]

Thanks, yes the code underneath the line:

Application.CutCopyMode = False

all works when run in a separate module but I still get the run time error when I run the whole thing altogether?

 

[Norie]

Where are you getting the error and what exactly is the code meant to do?

 

[syntaxed]

Human_doing:

Try the change I suggested, i.e. adding the two dots:

.Range(.Cells(2, 1), .Cells(lastrow, LastCol)).Sort Key1:=.Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

 

[Human_doing]

<P>Hi,</P>
<P> </P>
<P> syntaxed, I have added the dots and yes the code works when run as an isolated module so thanks for your help. However there is still the issue that when both parts of the macro are run together, I get the run time error. This is what the macro is looking to achieve:</P>
<P> </P>
<P>1. Bring up dialog box asking for user to select file.</P>
<P>2. Copy sheet 1 of selected file to new workbook.</P>
<P>3. Sheet 1 will have a range of data on it, macro needs to create new worksheet for each variable in column A and paste all rows that meet that variable on to it, i.e. if the sheet has 100 rows, 25 'red', 25 'green', 25 'blue', 25 'orange' then 4 new worksheets would be created, one for each colour, and the 25 matching rows for each pasted on to each sheet. </P>
<P> </P>
<P> Both 'parts' of the macro appear to work fine in isolation but are not working when put together as one? The macro does create a new workbook and pastes sheet 1 of selected file on to it but then doesn't do the loop of creating new sheets and copy/pasting?</P>
<P> </P>
<P> Thanks </P>

 

[Norie]

Do you need the workbook you open after you've copied the data from it?

If you don't then close it as soon as you've copied the data.

Anyway, try this code.

I've made a few assumptions, some of which I've added comments for - hopefully the rest will be obvious.

If they aren't post back.

Option Explicit

Sub TestIt()
Dim wbData As Workbook
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim NewFN As Variant
Dim LastRow As Long, LastCol As Long
Dim I As Long
Dim iStart As Long
Dim iEnd As Long
Dim ws As Worksheet

    NewFN = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Select the file with raw data for the report")

    If NewFN = False Then
        ' They pressed Cancel
        MsgBox "Stopping because you did not select a file"
        Exit Sub
    Else

        Application.ScreenUpdating = False
 
       ' open workbook selected by the user and create a reference to it.
        Set wbData = Workbooks.Open(Filename:=NewFN) ' ThisWorkbook 
 
        Set wbNew = Workbooks.Add(xlWBATWorksheet)    ' creates a new workbook with one worksheet

    End If
 
    wbData.Worksheets(1).Cells.Copy wbNew.Worksheets(1).Range("A1")
 
    ' close the workbook data was copied from if it's not needed anymore
    wbData.Close SaveChanges:=False

    ' set a reference to the worksheet in the new workbook which the data has been copied to

    Set wsData = wbNew.Worksheets(1)
 
    With wsData
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(2, 1), Cells(LastRow, LastCol)).Sort Key1:=Range("A2"), Order1:=xlAscending, _
                                                           Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End With
 
    ' now split the data into separate worksheets for each unique value in column A
    iStart = 2
 
    For I = 2 To LastRow
 
        If wsData.Range("A" & I).Value <> wsData.Range("A" & I + 1).Value Then
 
            iEnd = I
 
            Set wsNew = Sheets.Add(After:=wbNew.Sheets(wbNew.Sheets.Count))
 
            On Error Resume Next
            wsNew.Name = wsData.Range("A" & iStart).Value
            On Error GoTo 0
 
            ' create headers on in row 1 of new worksheet from those in row 1 of data sheet

            wsNew.Range("A1").Resize(, LastCol).Value = wsData.Range("A1").Resize(, LastCol).Value
 
            With wsNew.Rows(1)
                .HorizontalAlignment = xlCenter
                With .Font
                    .ColorIndex = 5
                    .Bold = True
                End With
            End With
 
            wsData.Range(wsData.Cells(iStart, 1), wsData.Cells(iEnd, LastCol)).Copy Destination:=wsNew.Range("A2")
 
            iStart = iEnd + 1

        End If

    Next I
 
    Application.CutCopyMode = False

    Application.ScreenUpdating = True
 
End Sub

The only other thing is that I used the workbook the code was instead of opening a workbook the user selected.

I commented that out though.

 

[Human_doing]

Thanks for your help this has solved the problem, I really appreciate your help.