CODEWITHSUNDEEP
vbaexcel
Adem
Adem

Reputation: 45

CSV saves on wrong location

My code is saving in Local/temporary somewhere - It's supposed to save on Desktop, AND if it already exists, ask before overwriting. Can you help me?

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

Upvotes: 3

Views: 79

Answers (1)

warner_sc
warner_sc

Reputation: 848

Try using Environ$("USERPROFILE") to create a default desktop save path, then create a simple message box with YesNo option as the code shows:

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

Upvotes: 1

Related Questions