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

ADER_34 · Cuma saat 10:56'de

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 · Cuma saat 11:06'de

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 · Cuma saat 14:28'de

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 · Cuma saat 15:19'de

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 · Cuma saat 15:46'de

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 · Pazartesi saat 12:49'de

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

volki_112 · Pazartesi saat 13:25'de

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 · Pazartesi saat 14:29'de

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 · Dün 11:01 da

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

ADER_34 · Bugün 08:11

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 · Bugün 09:35

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 · Bugün 10:36

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

volki_112 · Bugün 10:43

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 · Bugün 15:48

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