masa üstüne ayrı isimlerde klasör oluşturma

ADER_34 · 3 Ekim 2025

Merhaba arkadaşlar örnek dosyamda "G" sütununda "EVRAK ID" "F" sütununda "SAHİP" isim ve soy isimleri var, makro kodunu çalıştırınca bilgisayarımın masa ütüne EVRAK ID ve "G" ve "F" sütunuda olan isim soy isme ait ayrı ayrı boş klasör açması bu mümkün mü? teşekkürler.

İndir Örnek klasör aç xlsm

Dosyayı indir Örnek klasör aç xlsm

dosya.co

volki_112 · 3 Ekim 2025

ADER_34' Alıntı:
Merhaba arkadaşlar örnek dosyamda "G" sütununda "EVRAK ID" "F" sütununda "SAHİP" isim ve soy isimleri var, makro kodunu çalıştırınca bilgisayarımın masa ütüne EVRAK ID ve "G" ve "F" sütunuda olan isim soy isme ait ayrı ayrı boş klasör açması bu mümkün mü? teşekkürler.

İndir Örnek klasör aç xlsm

Dosyayı indir Örnek klasör aç xlsm

dosya.co

deneyiniz.

Kod:

Sub KlasorleriOlustur()

    Dim ws As Worksheet
    Dim sonSatir As Long, i As Long
    Dim evrakID As String, sahip As String
    Dim klasorAdi As String, masaustu As String
    
    ' Aktif sayfa
    Set ws = ActiveSheet
    
    ' Son satırı bul
    sonSatir = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    
    ' Kullanıcının masaüstü yolu
    masaustu = Environ("USERPROFILE") & "\Desktop\"
    
    ' Satırları dolaş
    For i = 2 To sonSatir ' Başlık varsa 2. satırdan başla
        evrakID = Trim(ws.Cells(i, "G").Value)
        sahip = Trim(ws.Cells(i, "F").Value)
        
        If evrakID <> "" And sahip <> "" Then
            ' Klasör adı = EVRAKID + "_" + SAHİP
            klasorAdi = masaustu & evrakID & " - " & sahip
            
            ' Eğer klasör yoksa oluştur
            If Dir(klasorAdi, vbDirectory) = "" Then
                MkDir klasorAdi
            End If
        End If
    Next i
    
    MsgBox "Klasörler başarıyla oluşturuldu!", vbInformation

End Sub

ADER_34 · 3 Ekim 2025

Merhaab volki12 kodlar sorunsuz çalışıyor çok teşekkür ederim,tek bir isteğim var sizden masaüstünde dağınık değilde "EVRAK ID" adlı bir klasör içnde toplasın,teşekkürler.

volki_112 · 3 Ekim 2025

ADER_34' Alıntı:
Merhaab volki12 kodlar sorunsuz çalışıyor çok teşekkür ederim,tek bir isteğim var sizden masaüstünde dağınık değilde "EVRAK ID" adlı bir klasör içnde toplasın,teşekkürler.

bunu deneyiniz.

Kod:

Sub KlasorleriOlustur()

    Dim ws As Worksheet
    Dim sonSatir As Long, i As Long
    Dim evrakID As String, sahip As String
    Dim klasorAdi As String, masaustu As String, anaKlasor As String
    
    ' Aktif sayfa
    Set ws = ActiveSheet
    
    ' Son satırı bul
    sonSatir = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    
    ' Kullanıcının masaüstü yolu
    masaustu = Environ("USERPROFILE") & "\Desktop\"
    
    ' Masaüstünde "EVRAK ID" adlı ana klasör oluştur (yoksa)
    anaKlasor = masaustu & "EVRAK ID"
    If Dir(anaKlasor, vbDirectory) = "" Then
        MkDir anaKlasor
    End If
    
    ' Satırları dolaş
    For i = 2 To sonSatir ' Başlık varsa 2. satırdan başla
        evrakID = Trim(ws.Cells(i, "G").Value)
        sahip = Trim(ws.Cells(i, "F").Value)
        
        If evrakID <> "" And sahip <> "" Then
            ' Alt klasör adı = EVRAKID + "_" + SAHİP
            klasorAdi = anaKlasor & "\" & evrakID & " - " & sahip
            
            ' Eğer klasör yoksa oluştur
            If Dir(klasorAdi, vbDirectory) = "" Then
                MkDir klasorAdi
            End If
        End If
    Next i
    
    MsgBox "Klasörler başarıyla '" & anaKlasor & "' içine oluşturuldu!", vbInformation

End Sub

ADER_34 · 3 Ekim 2025

Volki 12 kodlar süper çalılşıyor çok teşekkür ederim,eğer mümkünse örnek dosyamda ki "G" ve "H" sütununda ki isim soy isimleri klasörler içine ayrı ayrı "EVRAK ID" ve isim "soy isim" olarak Excel dosyası olarak bölebilir miyiz? yani aynı dosya içinde hem klasör hemde excel sayfası olacak.

İndir Örnek klasör aç xlsm

Dosyayı indir Örnek klasör aç xlsm

dosya.co

ADER_34 · 6 Ekim 2025

merhaba volki 12 yardımcı olurmusun? excel dosyalarınıda ayrı ayrı atarsam süper olacak.teşekkürler

volki_112 · 6 Ekim 2025

ADER_34' Alıntı:
merhaba volki 12 yardımcı olurmusun? excel dosyalarınıda ayrı ayrı atarsam süper olacak.teşekkürler

kamu interneti paylaşım sitelerini açmıyor. dosyayı
https://localsend.org/tr buraya yukelyip link paylaşınız. burayı açıyor

ADER_34 · 6 Ekim 2025

Merhaba volki12 bende yükleyemedim ama yazdığınız kodların devamında, dosyam bu şekilde sabit sütunlardan oluşuyor,ayırmak istediğim "Evrak Id" kısımlarını filtreleyip masüstünde açılan EVRAK ID klasörlerinin içine örnek:EVRAK ID "14896" yi bul sahip Ahmet xx klasörünü içine ayrı excel olarak sayfa ayır kopyala.

Sıra	Özellik	Açıklama	Miktar	Birim	Temin Durumu	Evrak Id	Sahip
XX	XX	XX	XX	XX	XX	14896	Ahmet xx
XX	XX	XX	XX	XX	XX	14896	Ahmet xx
XX	XX	XX	XX	XX	XX	14896	Ahmet xx
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14903	XX11
XX	XX	XX	XX	XX	XX	14903	XX11
XX	XX	XX	XX	XX	XX	14903	XX11
XX	XX	XX	XX	XX	XX	15031	XX22
XX	XX	XX	XX	XX	XX	15060	XX22
XX	XX	XX	XX	XX	XX	15060	XX22
XX	XX	XX	XX	XX	XX	15104	XX

ADER_34 · 7 Ekim 2025

merhaba volki 112 yardımcı olurmusun?şuan çözüm bulamadım.teşekkürler.

ADER_34 · 8 Ekim 2025

günaydın volki 112,mail attığımda aynı ekte belirttiğim durum aynı yazdığınız kodlar, sorunsuz işimi görüyor, çok teşekkür ederim, eğer mümkün ise, "EVRAK ID" ayırıp masa üstüne ayrı ayrı klasör açtığında devamında ,aynı excel dosyasında aynı sütuna ("EVRAK ID)bakıp klasör değil de ayrı ayrı excel olarak bölmesi teşekkürler.

volki_112 · 8 Ekim 2025

ADER_34' Alıntı:
günaydın volki 112,mail attığımda aynı ekte belirttiğim durum aynı yazdığınız kodlar, sorunsuz işimi görüyor, çok teşekkür ederim, eğer mümkün ise, "EVRAK ID" ayırıp masa üstüne ayrı ayrı klasör açtığında devamında ,aynı excel dosyasında aynı sütuna ("EVRAK ID)bakıp klasör değil de ayrı ayrı excel olarak bölmesi teşekkürler.

deneyiniz.

Kod:

Sub EvrakKopyalariVeKlasorleriOlustur()

    Dim ws As Worksheet
    Dim sonSatir As Long, i As Long
    Dim evrakID As String, sahip As String
    Dim masaustu As String, kaynakDosya As String
    Dim klasorYolu As String, hedefDosya As String
    
    ' Aktif sayfa
    Set ws = ActiveSheet
    
    ' Son satırı bul
    sonSatir = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    
    ' Masaüstü yolu
    masaustu = Environ("USERPROFILE") & "\Desktop\"
    
    ' Kopyalanacak dosyanın yolu (örnek: bu dosyanın kendisi)
    kaynakDosya = ThisWorkbook.FullName
    
    ' Satırları dolaş
    For i = 2 To sonSatir
        evrakID = Trim(ws.Cells(i, "G").Value)
        sahip = Trim(ws.Cells(i, "H").Value)
        
        If evrakID <> "" And sahip <> "" Then
            
            ' --- Klasör yolu ---
            klasorYolu = masaustu & evrakID & "\"
            
            ' Eğer klasör yoksa oluştur
            If Dir(klasorYolu, vbDirectory) = "" Then
                MkDir klasorYolu
            End If
            
            ' --- Hedef dosya yolu ---
            hedefDosya = klasorYolu & evrakID & " - " & sahip & ".xlsx"
            
            ' Aynı dosya varsa yeniden kopyalama
            If Dir(hedefDosya) = "" Then
                FileCopy kaynakDosya, hedefDosya
            End If
            
        End If
    Next i
    
    MsgBox "Tüm klasörler ve dosyalar başarıyla oluşturuldu!", vbInformation

End Sub

ADER_34 · 8 Ekim 2025

Merhaba volki 112 denedim fakat "run-time 53" hatası alıyorum neden acaba?

volki_112 · 8 Ekim 2025

ADER_34' Alıntı:
Merhaba volki 112 denedim fakat "run-time 53" hatası alıyorum neden acaba?

gönderdiğiniz mail bana ulaşmadı dosyayı gönderir misiniz bana.
volki_112@hotmail.com

ADER_34 · 8 Ekim 2025

Merhaba volk112 şuan mail atamıyorum fakat arayıp bulduğum bu kodlar çalışma sayfasında ki tüm sayfaları ayrı ayrı masaüstüne bölüp çalışma kitabı yapıyor, ben ise ,"EVRAK ID" numarası "G" sütunu göre ayırıp (A1:I1) aralığında ki tüm dolu satıları alarak, sayfalara bölmesini ve masaüstüne "EVRAK ID " numarasını da kitap ismi olarak vermesini istiyorum, her bir "EVRAK ID" ayrı bir sayfa olacak yani .ilk fırsatta size mail atıcam. teşekkürler

Sub ayır()

Dim ws As Worksheet
Application.DisplayAlerts = False

For Each ws In ThisWorkbook.Worksheets
ws.Copy
ws_name = ws.Name
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & ws_name
ActiveWorkbook.Close
Next ws

Application.DisplayAlerts = True

End Sub

Sıra	Özellik	Açıklama	Miktar	Birim	Temin Durumu	Evrak Id	Sahip
XX	XX	XX	XX	XX	XX	14896	Ahmet xx
XX	XX	XX	XX	XX	XX	14896	Ahmet xx
XX	XX	XX	XX	XX	XX	14896	Ahmet xx
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14932	XX0
XX	XX	XX	XX	XX	XX	14903	XX11
XX	XX	XX	XX	XX	XX	14903	XX11
XX	XX	XX	XX	XX	XX	14903	XX11
XX	XX	XX	XX	XX	XX	15031	XX22
XX	XX	XX	XX	XX	XX	15060	XX22
XX	XX	XX	XX	XX	XX	15060	XX22
XX	XX	XX	XX	XX	XX	15104	XX

ADER_34 · 9 Ekim 2025

günaydın volki 112 biraz daha açıklama yaptım eğer mümkün ise yardımcı olurumsun? teşekkürler.

Korhan Ayhan · 9 Ekim 2025

Deneyiniz..

C++:

Option Explicit

Sub Create_Folder_and_Excel_Files()
    Dim ws As Worksheet
    Dim sonSatir As Long, masaustu As String, anaKlasor As String
    Dim fso As Object
    Dim evrakID As String, temin As String, isim As String
    Dim klasorAdi As String, dosyaAdi As String
    Dim wbYeni As Workbook
    Dim dictKlasor As Object, dictDosya As Object
    Dim keyKlasor As String, keyDosya As String
    Dim rngVeri As Range, rngFiltre As Range
    
    ' Performans artırma
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    sonSatir = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dictKlasor = CreateObject("Scripting.Dictionary")
    Set dictDosya = CreateObject("Scripting.Dictionary")
    
    ' Masaüstü ve ana klasör
    masaustu = Environ("USERPROFILE") & "\Desktop\"
    anaKlasor = masaustu & "EVRAK ID"
    
    ' Ana klasör varsa sil
    If Dir(anaKlasor, vbDirectory) <> "" Then
        If MsgBox("Masaüstünde 'EVRAK ID' klasörü var. Silinsin mi?", vbYesNo + vbCritical + vbDefaultButton2) = vbYes Then
            fso.DeleteFolder anaKlasor, True
        Else
            MsgBox "İşlem iptal edildi.", vbExclamation
            GoTo Cleanup
        End If
    End If
    
    MkDir anaKlasor
    
    ' Tüm veri aralığı
    Set rngVeri = ws.Range("A1:H" & sonSatir)
    
    Dim i As Long
    For i = 2 To sonSatir
        evrakID = Trim(ws.Cells(i, "G").Value)
        temin = Trim(ws.Cells(i, "F").Value)
        isim = Trim(ws.Cells(i, "H").Value)
        
        If evrakID <> "" And temin <> "" And isim <> "" Then
            
            ' 1 Klasör oluştur
            keyKlasor = evrakID & " - " & temin
            klasorAdi = anaKlasor & "\" & keyKlasor
            If Not dictKlasor.exists(keyKlasor) Then
                On Error Resume Next
                MkDir klasorAdi
                On Error GoTo 0
                dictKlasor.Add keyKlasor, klasorAdi
            End If
            
            ' 2 Dosya oluştur
            dosyaAdi = evrakID & " - " & isim
            ' Yasaklı karakterleri temizle
            dosyaAdi = Replace(dosyaAdi, "/", " ")
            dosyaAdi = Replace(dosyaAdi, "\", " ")
            dosyaAdi = Replace(dosyaAdi, ":", " ")
            dosyaAdi = Replace(dosyaAdi, "*", " ")
            dosyaAdi = Replace(dosyaAdi, "?", " ")
            dosyaAdi = Replace(dosyaAdi, """", " ")
            dosyaAdi = Replace(dosyaAdi, "<", " ")
            dosyaAdi = Replace(dosyaAdi, ">", " ")
            dosyaAdi = Replace(dosyaAdi, "|", " ")
            
            keyDosya = klasorAdi & "\" & dosyaAdi
            
            If Not dictDosya.exists(keyDosya) Then
                Set wbYeni = Workbooks.Add
                wbYeni.Sheets(1).Name = "Veriler"
                dictDosya.Add keyDosya, wbYeni
            Else
                Set wbYeni = dictDosya(keyDosya)
            End If
            
            ' 3 Filtrele + CurrentRegion ile veri kopyala
            ws.Range("A1:H" & sonSatir).AutoFilter Field:=7, Criteria1:=evrakID ' G
            ws.Range("A1:H" & sonSatir).AutoFilter Field:=6, Criteria1:=temin ' F
            ws.Range("A1:H" & sonSatir).AutoFilter Field:=8, Criteria1:=isim ' H
            
            On Error Resume Next
            ws.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wbYeni.Sheets("Veriler").Range("A1")
            On Error GoTo 0
            
            wbYeni.Sheets("Veriler").Activate
            Range("A1").Select
            
            DoEvents
            Application.CutCopyMode = False
            
            ' AutoFilter temizle
            ws.AutoFilterMode = False
            
        End If
    Next i
    
    ' 4 Kaydet ve kapat
    Dim key As Variant
    For Each key In dictDosya.Keys
        Set wbYeni = dictDosya(key)
        wbYeni.Sheets("Veriler").Columns("A:H").AutoFit
        Application.DisplayAlerts = False
        wbYeni.SaveAs Filename:=key & ".xlsx", FileFormat:=51
        Application.DisplayAlerts = True
        wbYeni.Close False
    Next key
    
    MsgBox "İşlem tamamlandı!" & vbCrLf & vbCrLf & _
           "Klasörler ve dosyalar oluşturuldu.", vbInformation

    ' Oluşan ana klasörü aç
    Shell "explorer.exe """ & anaKlasor & """", vbNormalFocus

Cleanup:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

ADER_34 · 9 Ekim 2025

Merhaab Korhan bey kodlar için teşekkür ederim, kodlar hata vermiyor,klasör oluşturulurdu diyor, EVRAK ID klasörünü siliyor, başka bir işlem olmuyor..ne yapmam gerek.

Korhan Ayhan · 9 Ekim 2025

Küçük bir revize yaptım. Tekrar deneyiniz...

ADER_34 · 14 Ekim 2025

volki 112 ve Korhan bey her 2 kodda amacına göre süper ve sorunsuz. Çok teşekkür ederim. Sorun çözülmüştür iyi çalışmalar.

masa üstüne ayrı isimlerde klasör oluşturma

ADER_34

İndir Örnek klasör aç xlsm

volki_112

İndir Örnek klasör aç xlsm

ADER_34

volki_112

ADER_34

İndir Örnek klasör aç xlsm

ADER_34

volki_112

ADER_34

ADER_34

ADER_34

volki_112

ADER_34

volki_112

ADER_34

ADER_34

Korhan Ayhan

Administrator

ADER_34

Korhan Ayhan

Administrator

ADER_34