Excel 2007, necesito una macro que me crea una carpeta en mi escritorio y guarde en la misma la hoja activa

Ta tengo una macro que hace algo parecido. Pero necesito que las carpetas "PEDIDOS LAMA" Y "HISTORIAL CLIENTES LAMA" se creen solas en el escritorio y si ya están creadas que no se dupliquen que use la que ya esta.

Acá dejo la macro quizás me puedan ayudar a modificarla, por favor

gracias...

Tengo excel 2007

Sub Guardarhoja()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'Por.Dante Amor
' Macro para crear carpeta, guardar una hoja
    ActiveSheet.Unprotect
    ActiveSheet.Range("$F$20:$F$224").AutoFilter Field:=1
     'se impide que se ejecute la macro CHANGE de la hoja
    Application.EnableEvents = False
    Range("F20:I224").Select
    Selection.Locked = False
    Range("BM20:BN224").Select
    Selection.Copy
    Range("F20:G224").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    ActiveSheet.Range("$F$20:$F$224").AutoFilter Field:=1, Criteria1:="<>"
    Range("F4:G5").Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Range("F4:G5").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("G7").Select
    Application.CutCopyMode = False
   'Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set l1 = ThisWorkbook
    Set h1 = l1.ActiveSheet
    ruta = "C:\Users\pablo\Desktop\PEDIDOS LAMA\"
    'ruta = "C:\trabajo\"
    carp = "pedidos " & Format(Date, "dd-mm-yyyy")
    nomb = h1.[G7] & " " & Format(h1.[F4], "dd-mm-yyyy-hhmmss")
    '
    rut2 = ruta & carp
    If Dir(rut2, vbDirectory) = "" Then
        MkDir rut2
    End If
    '
    h1.Copy
    Set l2 = ActiveWorkbook
    l2.SaveAs Filename:=rut2 & "\" & nomb & ".xls", _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    'l2.SaveAs rut2 & "\" & nomb & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    l2.Close
    ' guardar en carpetas pedidos clientes
     Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set l1 = ThisWorkbook
    Set h1 = l1.ActiveSheet
    ruta = "C:\Users\Pablo\Desktop\HISTORIAL CLIENTES LAMA\"
    'ruta = "C:\trabajo\"
    carp = "pedidos " & [G7]
    nomb = h1.[G7] & " " & Format(h1.[F4], "dd-mm-yyyy-hhmmss") & "-" & [I3]
    '
    rut2 = ruta & carp
    If Dir(rut2, vbDirectory) = "" Then
        MkDir rut2
    End If
    '
    h1.Copy
    Set l2 = ActiveWorkbook
    l2.SaveAs Filename:=rut2 & "\" & nomb & ".xls", _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    'l2.SaveAs rut2 & "\" & nomb & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    l2.Close
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowSorting:=True, AllowFiltering:=True
            'se vuelve a habilitar la macro CHANGE de la hoja
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    Application.CutCopyMode = False
    End Sub
    

Dejo la macro que tengo para que me ayuden a modificarla