vba - CSV 保存在错误的位置

Question

我的代码保存在本地/临时某处 - 它应该保存在桌面上，如果它已经存在，请在覆盖之前询问。你能帮我吗？

Sub Opgave8()
    Dim sh As Worksheet
    Dim Pth As String
    Application.ScreenUpdating = False
    Pth = ActiveWorkbook.Path
    Set sh = Sheets.Add

    For i = 2 To 18288
        If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
            sh.Cells(i, 2) = Worksheets("Base").Cells(i, 4)
        End If
    Next i

    sh.Move
    With ActiveWorkbook
        .SaveAs Filename:=Pth & "\AdminExport.csv", FileFormat:=xlCSV
        .Close False
    End With
    Application.ScreenUpdating = True

End Sub
Function UniqueRandDigits(x As Long) As String
    Dim i As Long
    Dim n As Integer
    Dim s As String
    Do
        n = Int(Rnd() * 10)
        If InStr(s, n) = 0 Then
            s = s & n
            i = i + 1
        End If
    Loop Until i = x + 1

    UniqueRandDigits = s
End Function

Answer 1

尝试使用Environ$("USERPROFILE")创建默认桌面保存路径，然后创建一个带有YesNo选项的简单消息框，如代码所示:

Sub Opgave8()
    Dim sh As Worksheet
    Dim Pth As String

    Application.ScreenUpdating = False

    ' Create default desktop path using windows user id
    user_id = Environ$("USERPROFILE")
    ' Create full path
    file_name$ = "\AdminExport.csv"
    Pth = user_id & "\Desktop" & file_name

    Set sh = Sheets.Add

    For i = 2 To 18288
        If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
            sh.Cells(i, 2) = Worksheets("Base").Cells(i, 4)
        End If
    Next i

    sh.Move

    If Dir(Pth, vbArchive) <> vbNullString Then
        overwrite_question = MsgBox("File already exist, do you want to overwrite it?", vbYesNo)
    End If

    If overwrite_question = vbYes Then
        With ActiveWorkbook
            .SaveAs Filename:=Pth, FileFormat:=xlCSV
            .Close False
        End With
    End If

    Application.ScreenUpdating = True

End Sub

Function UniqueRandDigits(x As Long) As String
    Dim i As Long
    Dim n As Integer
    Dim s As String
    Do
        n = Int(Rnd() * 10)
        If InStr(s, n) = 0 Then
            s = s & n
            i = i + 1
        End If
    Loop Until i = x + 1

    UniqueRandDigits = s
End Function