Salvar imagem automatico com qualquer usuario

pode me ajudar?
tenho este código abaixo funciona blz no meu pc com meu usuário
quando outro usuário vai usar não roda em outro pc


ob: já tentei
ConferePasta = "C:\Users\Public\Desktop\ENVIO WHATSAPP"
no meu pc funciona, meu colega a pasta fica marcada somente leitura não consigo alterar.

Sub CRIAR_PASTA_DESKTOP()
Dim ConferePasta As String
'ConferePasta = "C:\NOVO1"
ConferePasta = "C:\Users\armando\Desktop\ENVIO WHATSAPP"
If Dir(ConferePasta, vbDirectory) = “” Then
MkDir ConferePasta
MsgBox "O diretório: " & ConferePasta & " FOI CRIADO! ARQUIVO SALVO SÓ FAZER O ENVIO", vbInformation, "AVISO"
End If
End Sub


Sub SALVAR_IMAGEM()
    call CRIAR_PASTA_DESKTOP
   Sheets("IMPRIMIR").Select
    Dim rVis As Range, k As Long
  For Each rVis In Range("A:A").SpecialCells(xlCellTypeVisible) '(PRIMEIRA COLUNA)
    k = k + 1: If k = [A1] + 16 Then Exit For                    '[SOMA DE LIMHAS]+ TOTAL CABECALHO
  Next rVis
Dim rgExp As Range: Set rgExp = Sheets("IMPRIMIR").Range("D4:U" & rVis.Row) '("SELEÇÃO DA AREA
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, TOP:=rgExp.TOP, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\Users\armando\Desktop\Envio Whatsapp\" & [G12].Value & " " & [G1].Value & " Marcas ate dia " & [B1].Value & ".jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
     Sheets("MENU").Select
     Range("N6").Select
  End Sub

ConferePasta = "C:\Users\armando\Desktop\ENVIO WHATSAPP"
Da forma que você colocou realmente não vai dar certo, porque "C:\Users\" é comum a todos os usuarios mas a partir "armando\Desktop\..." somente o usuario "armando" irá ter acesso a este diretorio.

sujestão:

Sub CRIAR_PASTA_DESKTOP()
Dim ConferePasta As String
'ConferePasta = currentProject.path & "\NOVO1"
ConferePasta = currentProject.path & "\NOVO1"
If Dir(ConferePasta, vbDirectory) = "" Then
MkDir ConferePasta
MsgBox "O diretório: " & ConferePasta & " FOI CRIADO! ARQUIVO SALVO SÓ FAZER O ENVIO", vbInformation, "AVISO"
End If
End Sub


Sub SALVAR_IMAGEM()
call CRIAR_PASTA_DESKTOP
Sheets("IMPRIMIR").Select
Dim rVis As Range, k As Long
For Each rVis In Range("A:A").SpecialCells(xlCellTypeVisible) '(PRIMEIRA COLUNA)
k = k + 1: If k = [A1] + 16 Then Exit For '[SOMA DE LIMHAS]+ TOTAL CABECALHO
Next rVis
Dim rgExp As Range: Set rgExp = Sheets("IMPRIMIR").Range("D4:U" & rVis.Row) '("SELEÇÃO DA AREA
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, TOP:=rgExp.TOP, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export currentProject.path & "\NOVO1" & [G12].Value & " " & [G1].Value & " Marcas ate dia " & [B1].Value & ".jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
Sheets("MENU").Select
Range("N6").Select
End Sub

Bom dia, amigo rubenscouto
não funcionou adicionei um modelo em anexo
Pasta e local quero salvar é "C:\Users\Public\Desktop\ENVIO WHATSAPP"
ex : "C:\Users\armando\Desktop\ENVIO WHATSAPP"" eu consigo rodar.
se enviar por e-mail para meus colegas
outros pc não tem meu usuario armando não funciona.

agradeço se puder dar uma forca.
obrigado

Olá a todos,

Armando, chegou a resolver?
Se ainda tem a questão do utilizador ajuste com :

Environ("username")

Abraço