Find Anyones Desktop Folder

Hi,

I am having an issue with trying to find anyone's desktop folder. I'm trying to write a path to the desktop but once again the desktop is different on every computer. The problem line is in red...



Any Idea's Thank You, Mike

Sub CombineSheetsFromAllFilesInADirectoryLA()
  
 Dim Path      As String 'string variable to hold the path to look through
 Dim FileName  As String 'temporary filename string variable
 Dim tWB       As Workbook 'temporary workbook (each in directory)
 Dim tWS       As Worksheet 'temporary worksheet variable
 Dim mWB       As Workbook 'master workbook
 Dim aWS       As Worksheet 'active sheet in master workbook
 Dim RowCount  As Long 'Rows used on master sheet
 Dim uRange    As Range 'usedrange for each temporary sheet
 Dim LastColm  As Range 'Range variable, will be used to find the last used column
  
  '***** Set folder to cycle through *****
 Path = SpecialFolder("Desktop") & "\Production 2009\" & "\Large Area\" 
 'Path = "G:\Hazleton Production\2009 Production\Individual Production\Varsity Area Pickers"
 
 Application.EnableEvents = False 'turn off events
 Application.ScreenUpdating = False 'turn off screen updating
 
    Set mWB = Workbooks.Add(1) 'create a new one-worksheet workbook
    Set aWS = mWB.ActiveSheet 'set active sheet variable to only sheet in mWB
 
    If Right(Path, 1) <> Application.PathSeparator Then 'if path doesnt end in "\"
        Path = Path & Application.PathSeparator 'add "\"
    End If
 FileName = Dir(Path & "*.xls", vbNormal) 'set first file's name to filename variable
    Do Until FileName = "" 'loop until all files have been parsed
        If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.name Then
    Set tWB = Workbooks.Open(FileName:=Path & FileName) 'open file, set to tWB variable
     For Each tWS In tWB.Worksheets 'loop through each sheet
    Set uRange = tWS.Range("A3", tWS.Cells(tWS.UsedRange.Row + tWS.UsedRange.Rows _
    .Count - 1, tWS.UsedRange.Column + tWS.UsedRange.Columns.Count - 1)) 'set used range
    If RowCount + uRange.Rows.Count > 65536 Then 'if the used range wont fit on the sheet
     aWS.Columns.AutoFit 'autofit mostly-used worksheet's columns
     Set LastColm = aWS.Cells.Find(What:="*", After:=Range("IV"), _
      SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
     If LastColm.Column <> 255 Then
      aWS.Range(aWS.Columns(LastColm.Column + 1), aWS.Columns(255)).Delete
     End If
     RowCount = aWS.UsedRange.Rows.Count 'Reset scroll bars and last cell
     Set aWS = mWB.Sheets.Add(After:=aWS) 'add a new sheet that will accommodate data
     RowCount = 0 'reset RowCount variable
    End If
    If RowCount = 0 Then 'if working with a new sheet
     aWS.Range("A1", aWS.Cells(1, uRange.Columns.Count)).Value = _
     tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Value 'copy headers from tWS
     aWS.Range("IV1").Value = "Source Sheet"
     RowCount = 1 'add one to rowcount
    End If
    With aWS.Range("A" & RowCount + 1).Resize(uRange.Rows.Count, uRange.Columns.Count)
     .Value = uRange.Value 'move data from temp sheet to data sheet
     Intersect(.EntireRow, aWS.Columns("J")).Value = tWS.name
    End With
    RowCount = RowCount + uRange.Rows.Count 'increase rowcount accordingly
   Next 'tWS
   tWB.Close False 'close temporary workbook without saving
  End If
  FileName = Dir() 'set next file's name to FileName variable
 Loop
 aWS.Columns.AutoFit 'autofit columns on last data sheet
 Set LastColm = aWS.Cells.Find(What:="*", After:=Range("IV1"), _
  SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
 If LastColm.Column <> 255 Then
  aWS.Range(aWS.Columns(LastColm.Column + 1), aWS.Columns(255)).Delete
 End If
 RowCount = aWS.UsedRange.Rows.Count 'Reset scroll bars and last cell
 mWB.Sheets(1).Select 'select first data sheet on master workbook
 Application.EnableEvents = True 're-enable events
 Application.ScreenUpdating = True 'turn screen updating back on
  
  'Clear memory of the object variables
 Set tWB = Nothing
 Set tWS = Nothing
 Set mWB = Nothing
 Set aWS = Nothing
 Set uRange = Nothing
 Set LastColm = Nothing
 Stop
 
 
 Call LAEXTRABLANKS
 
End Sub

I have used this in the past to save files to anyone's desktop but now I have to find or look for these folders so I can access the files?

Function SpecialFolderpath() As String
     
    Dim objWSHShell As Object
    Dim strSpecialFolderPath
     
     'On  Error GoTo ErrorHandler
     ' Create a shell object
    Set objWSHShell = CreateObject("WScript.Shell")
     '  Find out the path to the passed special folder,
     '  just change the "Desktop" for one of the other options
    SpecialFolderpath = objWSHShell.SpecialFolders("Desktop")
     ' Clean up
    Set objWSHShell = Nothing
    Exit Function
ErrorHandler:
     
     MsgBox "Error finding " & strSpecialFolder, vbCritical + vbOKOnly, "Error"
End Function

Sub LAMoveMe()
Dim prodPath As String
Dim Folder As String

Application.DisplayAlerts = False
prodPath = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & _
                          "\Production 2009\"
                          
If Dir(prodPath, vbDirectory) <> "." Then MkDir prodPath
Folder = CreateObject("Wscript.Shell").SpecialFolders("Desktop") & _
                          "\Production 2009\Large Area\"
    If Dir(Folder, vbDirectory) <> "." Then MkDir Folder
    
    ActiveWorkbook.SaveAs Folder & ActiveWorkbook.name

Application.DisplayAlerts = True
Call Closeme
End Sub