KLASÖR TAŞI

[comp_wolf]

İyi günler herkese
ben exel dosyamın içine bir buton ile mevcut açık olan exelimi bulunduğu klasör ile başka bir adrese taşımak istiyorum klasörün içindeki başka dosyalar ile komple bu konuda yardımcı olabilecek varmı nasıl bir kodlamam gerekir.
teşekkür ederim şimdiden...

 

[ÖmerBey]

Merhaba,
Dosya konumunu kendinize göre düzenleyip aşağıdaki kodu deneyiniz.

Sub KlasorTasi()
Dim Ds As Object
Dim eski As String
Dim yeni As String
ThisWorkbook.Save
ThisWorkbook.ChangeFileAccess xlReadOnly
eski = ThisWorkbook.Path
yeni = "C:\Deneme\"
Set Ds = CreateObject("Scripting.FileSystemObject")
Ds.MoveFolder Source:=eski, Destination:=yeni
MsgBox "Klasör " & yeni & " konumuna taşındı."
ThisWorkbook.Close
End Sub

 

[comp_wolf]

Merhaba,
Dosya konumunu kendinize göre düzenleyip aşağıdaki kodu deneyiniz.

Sub KlasorTasi()
Dim Ds As Object
Dim eski As String
Dim yeni As String
ThisWorkbook.Save
ThisWorkbook.ChangeFileAccess xlReadOnly
eski = ThisWorkbook.Path
yeni = "C:\Deneme\"
Set Ds = CreateObject("Scripting.FileSystemObject")
Ds.MoveFolder Source:=eski, Destination:=yeni
MsgBox "Klasör " & yeni & " konumuna taşındı."
ThisWorkbook.Close
End Sub

Üstat çok teşekkürler tam istediğim gibi çok sağol.
bir şey daha sorsam size peki buraya
A5 hücresi dolu ise
C:\DENEME\A
Yok B5 hücresi dolu ise
C:\DENEME\B
yok C5 hücresi dolu ise
C:\DENEME\C
bunlardan hangisi dolu ise ona taşıması için ne eklemem gerekir.

 

[ÖmerBey]

Burada hedef klasörü yeni değişkeni olduğu için şarta bağlı olarak yeni değişkenini şu şekilde belirlerseniz sanırım istediğiniz olacaktır.

If Range("A5") <> "" Then
    yeni = "C:\DENEME\A\"
ElseIf Range("B5") <> "" Then
    yeni = "C:\DENEME\B\"
ElseIf Range("C5") <> "" Then
    yeni = "C:\DENEME\C\"
Else: Exit Sub
End If

 

[comp_wolf]

Üstat teşekkürler
ben kodu bu şekilde uyarladım kırmızı olan satırda hata verdi ama hücrelerin içi boş olduğu için hata verdi sanırım eğer boş ise uyarı mesajı verse de ona göre doldurup çalışsa kod olur mu ?
Dim Ds As Object
Dim eski As String
Dim yeni As String
ThisWorkbook.Save
ThisWorkbook.ChangeFileAccess xlReadOnly
eski = ThisWorkbook.Path
If Range("R12") <> "" Then
yeni = "\\10.0.0.10\ortakdata\ARAÇ TAKİP\KAPANAN\KASKO\"
ElseIf Range("R13") <> "" Then
yeni = "\\10.0.0.10\ortakdata\ARAÇ TAKİP\KAPANAN\TRAFİK\"
End If
Set Ds = CreateObject("Scripting.FileSystemObject")
Ds.MoveFolder Source:=eski, Destination:=yeni
MsgBox "Klasör " & yeni & " konumuna taşındı."
Application.Quit

 

[ÖmerBey]

Şu şekilde deneyiniz.

Set Ds = CreateObject("Scripting.FileSystemObject")
If Ds.FolderExists(yeni) = False Then
    MsgBox yeni & " klasörü bulunamadı."
    Exit Sub
Else
    ThisWorkbook.Save
    ThisWorkbook.ChangeFileAccess xlReadOnly
    Ds.MoveFolder Source:=eski, Destination:=yeni
End If
MsgBox "Klasör " & yeni & " konumuna taşındı."

 

[comp_wolf]

Şu şekilde deneyiniz.

Set Ds = CreateObject("Scripting.FileSystemObject")
If Ds.FolderExists(yeni) = False Then
    MsgBox yeni & " klasörü bulunamadı."
    Exit Sub
Else
    Ds.MoveFolder Source:=eski, Destination:=yeni
End If
MsgBox "Klasör " & yeni & " konumuna taşındı."

üstat çok teşekkürler, çok güzel oldu sağolasın. iyi günler dilerim

 

[ÖmerBey]

Rica ederim,
İyi günler, iyi çalışmalar...

 

[comp_wolf]

günlerdir aradığım ve uğraştığım konuyu sayenizde çok güzel bir şekilde çözdüm iyi çalışmalar

 

[ÖmerBey]

Tekrar merhaba,
Hedef klasör yolunun bulunamaması durumunda excel dosyasının salt okunur olması projenizin düzgün çalışmamasına sebep olabilir. Bu yüzden 6. mesajdaki kodu güncelledim. Kodun baş taraflarında yer alanThisWorkbook.Save ThisWorkbook.ChangeFileAccess xlReadOnly satırlarını 6. mesajdaki gibi ayarlarsanız problem olmaz sanıyorum.
İyi çalışmalar...