Son numaralı dosyayı buldurma

dsaffethoscan · Dün 15:42 da

Merhaba arkadaşlar, müşterilere teklifler veriyoruz. Bu tekliflerin bazıları onaylanıyor. Onaydan sonra üretim formları hazırlıyorum. Bu üretim formlarına 29.971-29.972 gibi numara veriyorum. Tüm üretim formları üretim formları adlı bir klasörün içinde kayıtlıdır. Yine bu klasörde şablon bir üretim formu da var. Yapmak istediğim bu klasördeki son numaralı formu makro ile bulsun. Sonra şablon formu açıp içindeki aj2 hücresine bulduğu son numarayı 1 arttırarak eklesin. Eklediğimiz bu yeni numara ile kaydetsin. Numarayı bir arttırarak kaydettiriyorum. Ama klasördeki son numaralı dosyayı makro ile bulduramıyorum.
Yardım edebilecek arkadaşlara şimdiden teşekkür ederin.

Ouzz_z · Dün 16:31 da

Kod:

Sub ExcelDosyalarindanA1Oku()
    Dim klasorYolu As String
    Dim dosyaAdi As String
    Dim tamYol As String
    Dim wb As Workbook
    Dim i As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' Klasör yolunu yaz (örnek: "C:\Klasorum\")
    klasorYolu = "klasör yolu\" 'sonda \ işareti kalmalı
    
    dosyaAdi = Dir(klasorYolu & "*.xlsx*")
    i = 2
    
    ' Başlıkları yaz
    With ThisWorkbook.Sheets(1)
        .Cells(1, 1).Value = "Dosya Adı"
        .Cells(1, 2).Value = "A1 Hücre Değeri"
    End With
    
    Do While dosyaAdi <> ""
        tamYol = klasorYolu & dosyaAdi
        
        ' Bu dosya açık değilse
        If dosyaAdi <> ThisWorkbook.Name Then
            On Error Resume Next
            Set wb = Workbooks.Open(tamYol, ReadOnly:=True)
            On Error GoTo 0
            
            If Not wb Is Nothing Then
                ' İlk görünen çalışma sayfasını al ve A1 değerini oku
                With ThisWorkbook.Sheets(1)
                    .Cells(i, 1).Value = dosyaAdi
                    .Cells(i, 2).Value = wb.Sheets(1).Range("A1").Text
                End With
                
                wb.Close SaveChanges:=False
                Set wb = Nothing
                i = i + 1
            End If
        End If
        
        dosyaAdi = Dir
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "Tamamlandı. " & i - 2 & " dosya işlendi.", vbInformation
End Sub

Dosya adlarını ve a1 hücre değerlerini sayfaya yazar. İsteğinize göre revize edebilirsiniz.

volki_112 · Dün 16:42 da

dsaffethoscan' Alıntı:
Merhaba arkadaşlar, müşterilere teklifler veriyoruz. Bu tekliflerin bazıları onaylanıyor. Onaydan sonra üretim formları hazırlıyorum. Bu üretim formlarına 29.971-29.972 gibi numara veriyorum. Tüm üretim formları üretim formları adlı bir klasörün içinde kayıtlıdır. Yine bu klasörde şablon bir üretim formu da var. Yapmak istediğim bu klasördeki son numaralı formu makro ile bulsun. Sonra şablon formu açıp içindeki aj2 hücresine bulduğu son numarayı 1 arttırarak eklesin. Eklediğimiz bu yeni numara ile kaydetsin. Numarayı bir arttırarak kaydettiriyorum. Ama klasördeki son numaralı dosyayı makro ile bulduramıyorum.
Yardım edebilecek arkadaşlara şimdiden teşekkür ederin.

Şablon dosyasini atarmisiniz.
Dosya.tc. dosya.co gibi paylasim siyesine dosyanizi yukleyip link verebilirsiniz. Klasordeki dosylarinizin isimlerinden bir kac foto atar misiniz. 29971 seklinde mi yaziyor. Yoksa 29.971 seklinde mi. Klasorde hic dosya yoksa rakam 1 den mi baslayacak. Ismi rakam ile yazilan dosyalaron formati xlsx mi xlsm mi ???

Bunlara cevap gelirse daha dogru sonuc elde edilir.

dsaffethoscan · Dün 18:04 da

Ouzz_z' Alıntı:

Kod:

Sub ExcelDosyalarindanA1Oku()
    Dim klasorYolu As String
    Dim dosyaAdi As String
    Dim tamYol As String
    Dim wb As Workbook
    Dim i As Long
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    ' Klasör yolunu yaz (örnek: "C:\Klasorum\")
    klasorYolu = "klasör yolu\" 'sonda \ işareti kalmalı
   
    dosyaAdi = Dir(klasorYolu & "*.xlsx*")
    i = 2
   
    ' Başlıkları yaz
    With ThisWorkbook.Sheets(1)
        .Cells(1, 1).Value = "Dosya Adı"
        .Cells(1, 2).Value = "A1 Hücre Değeri"
    End With
   
    Do While dosyaAdi <> ""
        tamYol = klasorYolu & dosyaAdi
       
        ' Bu dosya açık değilse
        If dosyaAdi <> ThisWorkbook.Name Then
            On Error Resume Next
            Set wb = Workbooks.Open(tamYol, ReadOnly:=True)
            On Error GoTo 0
           
            If Not wb Is Nothing Then
                ' İlk görünen çalışma sayfasını al ve A1 değerini oku
                With ThisWorkbook.Sheets(1)
                    .Cells(i, 1).Value = dosyaAdi
                    .Cells(i, 2).Value = wb.Sheets(1).Range("A1").Text
                End With
               
                wb.Close SaveChanges:=False
                Set wb = Nothing
                i = i + 1
            End If
        End If
       
        dosyaAdi = Dir
    Loop
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   
    MsgBox "Tamamlandı. " & i - 2 & " dosya işlendi.", vbInformation
End Sub

Dosya adlarını ve a1 hücre değerlerini sayfaya yazar. İsteğinize göre revize edebilirsiniz.

klasorYolu = " \\192.168.8.101\Fiyatlandirma\Is_Takip_Listesi_01-11-2012\"

dsaffethoscan · Dün 18:09 da

volki_112' Alıntı:
Şablon dosyasini atarmisiniz.
Dosya.tc. dosya.co gibi paylasim siyesine dosyanizi yukleyip link verebilirsiniz. Klasordeki dosylarinizin isimlerinden bir kac foto atar misiniz. 29971 seklinde mi yaziyor. Yoksa 29.971 seklinde mi. Klasorde hic dosya yoksa rakam 1 den mi baslayacak. Ismi rakam ile yazilan dosyalaron formati xlsx mi xlsm mi ???

Bunlara cevap gelirse daha dogru sonuc elde edilir.

Şu an son dosya "29980.xlsm"
dosya yolu "\\192.168.8.101\Fiyatlandirma\Is_Takip_Listesi_01-11-2012\"

dsaffethoscan · Dün 19:54 da

1980 nolu dosyanın linki
İndirme bağlantısı
https://wetransfer.com/downloads/db7391df6aca55a960fe4f4254a990e320250420164501/8578db5ae966e5135f0b2118825d457920250420164607/355a2b?t_exp=1745426701&t_lsid=9a48b133-ac92-48c2-8c05-199b91b3e89f&t_network=email&t_rid=ZW1haWx8YWRyb2l0fDFhYWFkMmY1LWNhNTktNGQyNS1iOGIyLTY2MDU0ODNiMDEwZg==&t_s=download_link&t_ts=1745167567

volki_112 · Dün 23:30 da

dsaffethoscan' Alıntı:
1980 nolu dosyanın linki
İndirme bağlantısı
https://wetransfer.com/downloads/db7391df6aca55a960fe4f4254a990e320250420164501/8578db5ae966e5135f0b2118825d457920250420164607/355a2b?t_exp=1745426701&t_lsid=9a48b133-ac92-48c2-8c05-199b91b3e89f&t_network=email&t_rid=ZW1haWx8YWRyb2l0fDFhYWFkMmY1LWNhNTktNGQyNS1iOGIyLTY2MDU0ODNiMDEwZg==&t_s=download_link&t_ts=1745167567

İstediğiniz kodları yazdım. Yeni dosya olarak kaydet butonuna bastığınızda istediğinizi yapar.

Biolightant · Dün 23:40 da

Merhaba,
@volki_112 kodlarını göremiyorum ama Alternatif çözüm olsun.
Kodları Uretim_Formu_Sablon.xlsm kitabınızın ThisWorkbook içine yazılacak

C++:

Private Sub Workbook_Open()
    Dim folderPath As String
    Dim fileName As String
    Dim largestNumber As Long
    Dim currentNumber As Long
    Dim fso As Object
    Dim folder As Object
    Dim file As Object

    ' Klasör yolunu belirleyin
    folderPath = "\\192.168.8.101\Fiyatlandirma\Is_Takip_Listesi_01-11-2012\"

    ' Dosya sistemine erişim
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)

    largestNumber = 0

    For Each file In folder.Files
        If LCase(fso.GetExtensionName(file.Name)) = "xlsm" Then
            ' Noktadan önceki kısmı al (uzantısız dosya adı)
            fileName = fso.GetBaseName(file.Name)
           
            ' Dosya adı sadece sayı mı diye kontrol et
            If IsNumeric(fileName) Then
                currentNumber = CLng(fileName)
                If currentNumber > largestNumber Then
                    largestNumber = currentNumber
                End If
            End If
        End If
    Next file

    ' Sonuç Uretim_Formu sayfasındaki AJ2 hücresine +1 artırılmış en büyük numarayı yaz
    ThisWorkbook.Sheets("Uretim_Formu").Range("AJ2").Value = largestNumber + 1
End Sub

volki_112 · Dün 23:50 da

volki_112' Alıntı:
İstediğiniz kodları yazdım. Yeni dosya olarak kaydet butonuna bastığınızda istediğinizi yapar.

Kullandigim Kodlar

Kod:

Private Sub CommandButton1_Click()

    Dim klasorYolu As String
    Dim fso As Object
    Dim klasor As Object
    Dim dosya As Object
    Dim dosyaAdiDizisi() As String
    Dim sayisalAdlar() As Long
    Dim sayac As Long
    Dim enBuyukNumara As Long
    Dim yeniNumara As Long
    Dim yeniDosyaAdi As String
    Dim i As Long, j As Long, temp As Long

    ' Dosyanın bulunduğu klasör
    klasorYolu = ThisWorkbook.Path

    ' Dosya sistemi nesneleri oluştur
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set klasor = fso.GetFolder(klasorYolu)

    ' Dosya adlarını topla
    ReDim dosyaAdiDizisi(1 To klasor.Files.Count)
    sayac = 0

    For Each dosya In klasor.Files
        If LCase(fso.GetExtensionName(dosya.Name)) = "xlsm" Then
            Dim dosyaTabanAdi As String
            dosyaTabanAdi = fso.GetBaseName(dosya.Name)

            If IsNumeric(Replace(dosyaTabanAdi, ".", "")) Then
                sayac = sayac + 1
                dosyaAdiDizisi(sayac) = dosyaTabanAdi
            End If
        End If
    Next dosya

    ' En büyük numarayı bul
    If sayac > 0 Then
        ReDim sayisalAdlar(1 To sayac)

        For i = 1 To sayac
            sayisalAdlar(i) = CLng(Replace(dosyaAdiDizisi(i), ".", ""))
        Next i

        ' Sıralama (Bubble Sort)
        For i = 1 To sayac - 1
            For j = i + 1 To sayac
                If sayisalAdlar(i) > sayisalAdlar(j) Then
                    temp = sayisalAdlar(i)
                    sayisalAdlar(i) = sayisalAdlar(j)
                    sayisalAdlar(j) = temp
                End If
            Next j
        Next i

        enBuyukNumara = sayisalAdlar(sayac)
    Else
        enBuyukNumara = 0
    End If

    ' Yeni numarayı AJ2 hücresine yaz
    yeniNumara = enBuyukNumara + 1
    ThisWorkbook.Sheets(1).Range("AJ2").Value = yeniNumara

    ' Yeni dosya adı oluştur ve kaydet
    yeniDosyaAdi = klasorYolu & "\" & yeniNumara & ".xlsm"

    On Error Resume Next
    ThisWorkbook.SaveCopyAs yeniDosyaAdi
    On Error GoTo 0

    MsgBox "Dosya '" & yeniDosyaAdi & "' adıyla kaydedildi.", vbInformation

End Sub

dsaffethoscan · Bugün 13:00

Yardım için herkese teşekkür ederim. Biraz yoğun bir gün. Akşama hepsini deneyeceğim.

dsaffethoscan · Bugün 13:53

Biolightant' Alıntı:

Merhaba,
@volki_112 kodlarını göremiyorum ama Alternatif çözüm olsun.
Kodları Uretim_Formu_Sablon.xlsm kitabınızın ThisWorkbook içine yazılacak

C++:

Private Sub Workbook_Open()
    Dim folderPath As String
    Dim fileName As String
    Dim largestNumber As Long
    Dim currentNumber As Long
    Dim fso As Object
    Dim folder As Object
    Dim file As Object

    ' Klasör yolunu belirleyin
    folderPath = "\\192.168.8.101\Fiyatlandirma\Is_Takip_Listesi_01-11-2012\"

    ' Dosya sistemine erişim
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)

    largestNumber = 0

    For Each file In folder.Files
        If LCase(fso.GetExtensionName(file.Name)) = "xlsm" Then
            ' Noktadan önceki kısmı al (uzantısız dosya adı)
            fileName = fso.GetBaseName(file.Name)
          
            ' Dosya adı sadece sayı mı diye kontrol et
            If IsNumeric(fileName) Then
                currentNumber = CLng(fileName)
                If currentNumber > largestNumber Then
                    largestNumber = currentNumber
                End If
            End If
        End If
    Next file

    ' Sonuç Uretim_Formu sayfasındaki AJ2 hücresine +1 artırılmış en büyük numarayı yaz
    ThisWorkbook.Sheets("Uretim_Formu").Range("AJ2").Value = largestNumber + 1
End Sub

Kodlar çok hızlı çalıştı. Teşekkür ederim.

dsaffethoscan · Bugün 13:55

volki_112' Alıntı:

Kullandigim Kodlar

Kod:

Private Sub CommandButton1_Click()

    Dim klasorYolu As String
    Dim fso As Object
    Dim klasor As Object
    Dim dosya As Object
    Dim dosyaAdiDizisi() As String
    Dim sayisalAdlar() As Long
    Dim sayac As Long
    Dim enBuyukNumara As Long
    Dim yeniNumara As Long
    Dim yeniDosyaAdi As String
    Dim i As Long, j As Long, temp As Long

    ' Dosyanın bulunduğu klasör
    klasorYolu = ThisWorkbook.Path

    ' Dosya sistemi nesneleri oluştur
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set klasor = fso.GetFolder(klasorYolu)

    ' Dosya adlarını topla
    ReDim dosyaAdiDizisi(1 To klasor.Files.Count)
    sayac = 0

    For Each dosya In klasor.Files
        If LCase(fso.GetExtensionName(dosya.Name)) = "xlsm" Then
            Dim dosyaTabanAdi As String
            dosyaTabanAdi = fso.GetBaseName(dosya.Name)

            If IsNumeric(Replace(dosyaTabanAdi, ".", "")) Then
                sayac = sayac + 1
                dosyaAdiDizisi(sayac) = dosyaTabanAdi
            End If
        End If
    Next dosya

    ' En büyük numarayı bul
    If sayac > 0 Then
        ReDim sayisalAdlar(1 To sayac)

        For i = 1 To sayac
            sayisalAdlar(i) = CLng(Replace(dosyaAdiDizisi(i), ".", ""))
        Next i

        ' Sıralama (Bubble Sort)
        For i = 1 To sayac - 1
            For j = i + 1 To sayac
                If sayisalAdlar(i) > sayisalAdlar(j) Then
                    temp = sayisalAdlar(i)
                    sayisalAdlar(i) = sayisalAdlar(j)
                    sayisalAdlar(j) = temp
                End If
            Next j
        Next i

        enBuyukNumara = sayisalAdlar(sayac)
    Else
        enBuyukNumara = 0
    End If

    ' Yeni numarayı AJ2 hücresine yaz
    yeniNumara = enBuyukNumara + 1
    ThisWorkbook.Sheets(1).Range("AJ2").Value = yeniNumara

    ' Yeni dosya adı oluştur ve kaydet
    yeniDosyaAdi = klasorYolu & "\" & yeniNumara & ".xlsm"

    On Error Resume Next
    ThisWorkbook.SaveCopyAs yeniDosyaAdi
    On Error GoTo 0

    MsgBox "Dosya '" & yeniDosyaAdi & "' adıyla kaydedildi.", vbInformation

End Sub

Sizinki de gayet güzel çalışıyor. Emeğiniz için size de teşekkür ederim.

volki_112 · Bugün 13:57

dsaffethoscan' Alıntı:
Sizinki de gayet güzel çalışıyor. Emeğiniz için size de teşekkür ederim.

benimkinde kodlar içine ayrı bir klasöt yolu belirtmenize gerek yok. Dosyanın bulunduğu klasörde arama yapar ve yeni dosyayı oraya kaydeder.

Son numaralı dosyayı buldurma

Ekli dosyalar