Dosya adını karşılaştırıp varsa yeni adla devam etsin

Mx@Raid · 5 Ağustos 2009

Arkadaşlar çalışma dosyasını kaydederken arada girilen isimden varsa 1 artırarak yeni dosya eklemek istiyorum. Yardımlarınız için teşekkürler.

Kod:

Kntr = 1
varmi = ThisWorkbook.Path & "\" & Trh & Chr(45) & Kntr & Chr(45) & DosyaAdı
If  Len(varmi) = True Then
Kntr = Kntr + 1
Dizin = varmi
End If

omerceri · 5 Ağustos 2009

Aşağıdaki gibi bir kodla olup olmadığı test edilebilir. "Kaç"ın sonucu sıfır değilse bir artır gibi.
Sub a()
With Application.FileSearch
.Filename = "DosyaAdı"
.LookIn = ActiveWorkbook.Path
.Execute
Kaç = .FoundFiles.Count
End With
End Sub

halit3 · 6 Ağustos 2009

mesaja cevap verdiler

baydeniro · 6 Ağustos 2009

Sayın omerceri merhaba. Bu kodun nasıl işlev gördüğünü anlayamadım. zamanınız varsa biraz açar mısınız lütfen ?

baydeniro · 6 Ağustos 2009

Sayın halit3, kod dosya var veya dosya yok olarak mesaj veriyor. Peki otomatik 1 artır özelliği var mı ?

omerceri · 6 Ağustos 2009

Sn serdarokan
Yukarıdaki kod o isimde bir dosya varsa kaç'ın değeri 1, yolsa 0 olacak. kaç'ı değeri 1 ise ona göre dosya ismini bir artıran kodyazıla bilir.
Dosya ismini baştan nerden alıyor. Bir artırınca yine bu isimde de bir dosya bulunabilir mi? O zaman dosya isminin sabit kalan kısmı hangisi gibi konularında bilgim olmadığımdan bir şey öneremedim.

baydeniro · 6 Ağustos 2009

Çok teşekkürler sayın ömerçeri. Buna örnek olabilecek kendinizden bir çalışmanız varsa çok makbule geçer !! Çok teşekkür ederim.

Mx@Raid · 6 Ağustos 2009

Sevgili arkadaşlar kodun tamamını ekliyorum meselenin anlaşılabilir olması için. Burada amaç içerisinde yer alan Kntr değer atamak ve aynı rakamdan varsa Kntr'ü bir değer atlamak.

Kod:

Sub OpenWordDoc()
Dim wdApp As Word.Application, wdDoc As Word.Document
Dim Trh, DosyaAdı As String

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

Kntr = 1
Kntr = Kntr + 1

Trh = Format(Date, "dd.mm.yyyy")
DosyaAdı = "CMRNL.doc"
Frmt = Trh & Chr(45) & Kntr & Chr(45)
Dizin = ThisWorkbook.Path & "\" & Frmt & DosyaAdı


'*****************************************
Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\" & DosyaAdı)
Set objTable = wdDoc.Tables(1)

            objTable.Cell(2, 9).Range.Text = Cells(2, 9).Value

        For j = 3 To 6
            objTable.Cell(j, 1).Range.Text = Cells(j, 1).Value
        Next

        For c = 8 To 11
            objTable.Cell(c, 1).Range.Text = Cells(c, 1).Value
            objTable.Cell(c, 5).Range.Text = Cells(c, 5).Value
        Next

            objTable.Cell(13, 1).Range.Text = Cells(13, 1).Value
            objTable.Cell(14, 1).Range.Text = Cells(14, 1).Value

        For g = 13 To 18
            objTable.Cell(g, 5).Range.Text = Cells(g, 5).Value
        Next

        For d = 19 To 22
            objTable.Cell(d, 5).Range.Text = Cells(d, 5).Value
        Next

            objTable.Cell(16, 1).Range.Text = Cells(16, 1).Value
            objTable.Cell(17, 1).Range.Text = Cells(17, 1).Value
            objTable.Cell(18, 1).Range.Text = Cells(18, 1).Value

            objTable.Cell(20, 1).Range.Text = Cells(20, 1).Value
            objTable.Cell(21, 1).Range.Text = Cells(21, 1).Value
            objTable.Cell(22, 1).Range.Text = Cells(22, 1).Value

        For i = 24 To 31
            For y = 1 To 9
                objTable.Cell(i, y).Range.Text = Cells(i, y).Value
        Next: Next

        For t = 33 To 39
            objTable.Cell(t, 1).Range.Text = Cells(t, 1).Value
        Next

        For u = 38 To 43
            For n = 7 To 9
                objTable.Cell(u, n).Range.Text = Cells(u, n).Value
        Next: Next

        For f = 41 To 43
            objTable.Cell(f, 1).Range.Text = Cells(f, 1).Value
        Next

        For p = 45 To 47
            objTable.Cell(p, 1).Range.Text = Cells(p, 1).Value
        Next

    For r = 45 To 47
        objTable.Cell(r, 3).Range.Text = Cells(r, 3).Value
    Next

    For k = 45 To 47
        objTable.Cell(k, 5).Range.Text = Cells(k, 5).Value
    Next

    For h = 49 To 54
        objTable.Cell(h, 1).Range.Text = Cells(h, 1).Value
    Next

    For v = 49 To 54
        objTable.Cell(v, 2).Range.Text = Cells(v, 4).Value
    Next

    For w = 49 To 54
        objTable.Cell(w, 6).Range.Text = Cells(w, 7).Value
    Next



'*****************************************
'wdDoc.PrintOut
wdDoc.Activate
wdDoc.SaveAs Dizin
wdDoc.Close
Set wdApp = Nothing
Set wdDoc = Nothing
Set objTable = Nothing
'Referanslardan "Microsoft Word ?.? Library" seçili olmalıdır.
End Sub

omerceri · 6 Ağustos 2009

Aşağıdaki kodu önerebilirim.
Dosyaadı = "degestir"
satırında dosyaismini belirlerken, dosya uzantısı kullanmayın.
Olmayan dosyaadı ise örnekte "degestir.xls", 1 tane varsa "degestir1.xls", 2 tane varsa "degestir2.xls" gibi bir isim üretecektir.
Sub a()
Dosyaadı = "degestir"
With Application.FileSearch
.Filename = Dosyaadı & "*"
.LookIn = ActiveWorkbook.Path
.Execute
If .FoundFiles.Count > 0 Then
Dosyaadı = Dosyaadı & .FoundFiles.Count & ".xls"
Else
Dosyaadı = Dosyaadı & ".xls"
End If
End With
MsgBox Dosyaadı
End Sub

baydeniro · 6 Ağustos 2009

İlginize çok teşekkür ederim.

Mx@Raid · 6 Ağustos 2009

Sn. omerceri maalesef olmadı. Benim verdiğim uygulama sonucu mudur? anlayamadım.

Kod:

DosyaAdı = "CMRNL"
dUzantı = ".doc"
Dzn = DosyaAdı & dUzantı

With Application.FileSearch
.Filename = DosyaAdı & "*"
.LookIn = ThisWorkbook.Path & "\"
.Execute
If .FoundFiles.Count > 0 Then
DosyaA = DosyaAdı & .FoundFiles.Count & dUzantı
Else
DosyaA = DosyaAdı & dUzantı
End If
End With

Dizin = ThisWorkbook.Path & "\" & Dzn

MsgBox Dizin

verdiğiniz kodu ayrı bir dosya olarak çalıştırdığımda sorun yok, yalnız benim makroda olmuyor.

omerceri · 6 Ağustos 2009

Böyle bir şey mi?
Sub a()
Dosyaadı = "degestir"
With Application.FileSearch
.Filename = Dosyaadı & "*"
.LookIn = ActiveWorkbook.Path
.Execute
If .FoundFiles.Count > 0 Then
Dosyaadı = Dosyaadı & .FoundFiles.Count & ".doc"
Else
Dosyaadı = Dosyaadı & ".doc"
End If
End With
MsgBox Dosyaadı
MsgBox ActiveWorkbook.Path & "/" & Dosyaadı
End Sub

baydeniro · 6 Ağustos 2009

Ben de bu kodu çalıştıramadım.

omerceri · 6 Ağustos 2009

Sn Mx@Raid
DosyaA nedir?
Sn serdarokan
anlamadım neyi çalıştıradınız sadece
MsgBox ActiveWorkbook.Path & "/" & Dosyaadı
satırını ekledim.

baydeniro · 6 Ağustos 2009

Sayın ömerçeri zamanınızı alıyorsam özür dilerim. Benim bu başlıktan beklentim şuydu : İçinde bulunduğum dosyayı kaydetmek istediğimde dosya adına bir numara eklemesiydi. Belki ben yanlış anlamışımdır.

omerceri · 6 Ağustos 2009

Sn serdarokan
Dosyaadı = Mid(ActiveWorkbook.Name, 1, Len(ActiveWorkbook.Name) - 4) & 1 & ".xls"

Mx@Raid · 6 Ağustos 2009

Sn. omerceri sizin kodda bir sorun yok. Benim kodlardan kaynaklanan bir sıkıntı var zannerdersem. Normalde ekleme yapıyor ancak alt satırda dosya adını bulmadığı için veri transferi gerçekleşmiyor.

Set wdDoc = wdApp.Documents.Open(ActiveWorkbook.Path & "\" & DosyaAdı)

Dosya adını karşılaştırıp varsa yeni adla devam etsin

Uzman