a sütununa göre alt klasör oluşturma ve bu klasörlere otonatik köprü ekleme yardım

[nostram]

iyi çalışmlara arkadaşlar excelde bulunan listemin a sütununa göre alt klasör oluşturan ve klasörlere otamatik olarak köprü atan makro lazım

 

[Ömer]

Merhaba,

Sorunuzu örnek dosya ekleyerek açıklarmısınız.

 

[nostram]

örnek dosya ektedir
burada a sütünunda bulunan isimlere bir klasör içinde alt klasör oluştursun aynı zamanda o isimdeki klasöre köprü atasın

 

[asi_kral]

Merhaba
Sayfanın kod bölümüne kopyalayın ve deneyin.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KLS As Variant
Application.EnableEvents = False
If Target <> Empty Then
If Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
Set KLS = CreateObject("Scripting.FileSystemObject")
KLS.createfolder "D:\" & Target
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim KLS As Variant
Application.EnableEvents = False
If Target <> Empty Then
If Intersect(Target, Range("A2:A" & Rows.Count)) Is Nothing Then _
Application.EnableEvents = True: Exit Sub
KLS = Shell("C:\WINDOWS\Explorer.exe D:\" & Target, vbNormalFocus)
End If
Application.EnableEvents = True
End Sub

Bu makroları kullanırken yapmanız gereken A2:A aralığında herhangi bir yazı yazın. Dosyayı o isimde oluştursun. Açmak istediğinizde ise sadece seçmeniz yeterli olacak.
Not : Ben klasörleri D:\ sürücüsünde oluşturttum. Açarkende D:\ sürücüsündeki dosyaları açtırttım. Olmayan bir dosyayı seçtiğinizde dizin hatası verecektir.

 

[nostram]

Asi kral ben bunu yapamadım örneğe ekleyip yükleyebilirmisiniz

 

[asi_kral]

Asi kral ben bunu yapamadım örneğe ekleyip yükleyebilirmisiniz

Kodu eklenmiş şekilde boş dosya yolluyorum. Siz A2:A aralığına herhangi bir şey yazın. D:\ sürücüsünü kontrol edin. ( Klasör Oluşmuş Olacak )
Sonra tekrar yazdığını hücreyi seçin sonuçları gözlemleyin. ( Bu da yazdığınız klasörü açacak )

 

[nostram]

Yardımcı olabilirsen çok sevinirim

 

[asi_kral]

Yardımcı olabilirsen çok sevinirim

Dosyayı ekleyemedim sanırım.

 

[nostram]

çok teşekür ederim asi kral

 

[nostram]

işimi gördü alternatif olarak kodlarıda buldum

arayan arkadaşlar olur ise kodlar

Sub KlsOluşma_ve_köprü_eklemek_olanlarada_köprü_ekleyen()
Dim kls, yol, a
Set kls = CreateObject("Scripting.FileSystemObject")
For i = 2 To [a65536].End(3).Row
' yol kısmına klasörün bulunduğu yerin adını yazıyoruz
yol = "D:\Users\huseyin.yildizturan\Desktop\denemeler\" & Cells(i, "a")
a = kls.FolderExists(yol)
If a = True Then

' uzun liste ise hepsine var olanları hepsine enter yapmaktansaa msgnohk önüne' koynak daha mantıklı
MsgBox yol & " isminde bir klasör var", 256, "UYARI"
Cells(i, "a").Select

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=yol
Else
kls.CreateFolder yol
End If

Cells(i, "a").Select

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=yol

Next i
MsgBox "Bitti"
Set ds = Nothing
End Sub

 

[asi_kral]

çok teşekür ederim asi kral

Kolay Gelsin.