Macro that will copy rows from spreadsheet into a new one into specific folder?

[Gostal]

I found this macro which allows you to copy rows from a spreadsheet into a new worksheet if it meets certain criteria, which is extremely useful to me.

In this particular example, it copies the rows that are associated with all of the unique entries from the second colum of a spreadsheet, exports them to a new spreadsheet, and saves the spreadsheet according to the name that is in the entry in the second column.

My problem is that these new worksheet that are created are save on the "My document" folder and I would like to save these new spreadsheet into a specific folder. I am not a programmer, but have tried to play with the code with no success. Maybe someone here can direct me in the correct path.

Here is the code that I have:

Sub details()    
Dim thisWB  As String    
Dim newWB As String    
    thisWB = ActiveWorkbook.Name    
        
    On Error Resume Next    
    Sheets("tempsheet").Delete    
    On Error GoTo 0    
        
    Sheets.Add    
    ActiveSheet.Name = "tempsheet"    
        
    Sheets("Sheet1").Select    
        
    If ActiveSheet.AutoFilterMode Then    
        Cells.Select    
            
        On Error Resume Next    
            
        ActiveSheet.ShowAllData    
            
        On Error GoTo 0    
        
    End If    
        
    Columns("B:B").Select    
    Selection.Copy    
        
    Sheets("tempsheet").Select    
    Range("A1").Select    
    ActiveSheet.Paste    
    Application.CutCopyMode = False    
        
    If (Cells(1, 1) = "") Then    
        lastrow = Cells(1, 1).End(xlDown).Row    
            
        If lastrow <> Rows.Count Then    
            Range("A1:A" & lastrow - 1).Select    
            Selection.Delete Shift:=xlUp    
        End If    
        
    End If    
        
    Columns("A:A").Select    
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _    
                CopyToRange:=Range("B1"), Unique:=True    
        
    Columns("A:A").Delete    
        
    Cells.Select    
    Selection.Sort _    
            Key1:=Range("A2"), Order1:=xlAscending, _    
            Header:=xlYes, OrderCustom:=1, _    
            MatchCase:=False, Orientation:=xlTopToBottom, _    
            DataOption1:=xlSortNormal    
        
    lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row    
        
    For suppno = 2 To lMaxSupp    
        
        Windows(thisWB).Activate    
        supName = Sheets("tempsheet").Range("A" & suppno)    
            
        If supName <> "" Then    
            Workbooks.Add    
            ActiveWorkbook.SaveAs supName    
            newWB = ActiveWorkbook.Name    
                
            Windows(thisWB).Activate    
            Sheets("Sheet1").Select    
            Cells.Select    
                
            If ActiveSheet.AutoFilterMode = False Then    
                Selection.AutoFilter    
            End If    
                
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _    
                        Operator:=xlAnd, Criteria2:="<>"    
                
            lastrow = Cells(Rows.Count, 2).End(xlUp).Row    
            Rows("1:" & lastrow).Copy    
                
            Windows(newWB).Activate    
            ActiveSheet.Paste    
            ActiveWorkbook.Save    
            ActiveWorkbook.Close    
                
        End If    
        
    Next    
        
    Sheets("tempsheet").Delete    
        
    Sheets("Sheet1").Select    
    If ActiveSheet.AutoFilterMode Then    
        Cells.Select    
        ActiveSheet.ShowAllData    
    End If    
End Sub

Any help would be appreciated,
Regards​

 

[AlphaFrog]

Try something like this (not tested). Add your file path in red.

        If supName <> "" Then    
            Workbooks.Add    
            ActiveWorkbook.SaveAs [COLOR="#FF0000"]"C:\MyFolder\" & [/COLOR]supName    
            newWB = ActiveWorkbook.Name

 

[Gostal]

Thank you very much...that worked great!

Gostal