Dosya isimlerini Hücreden alma mükerer isimleri +1,+2 diye sonuna ekleme Hk.

[link_me]

Merhabalar benimde elimde bir dosyam var hücre adına göre otomatik dosya adı veriyor.fakat mükerrer olan dosya isimlerini dosyanın sonuna 1-2-diye ekleme yaparak kaydetme nasıl yapabilirim.

' TANIMLAMALAR

Dim s1  As Worksheet, _
s2  As Worksheet, _
s3  As Worksheet, _
s4  As Worksheet

Set s1 = Sheets("yerli")
Set s2 = Sheets("gelen data")
Set s3 = Sheets("altformul")
Set s4 = Sheets("pdf")


yol = ThisWorkbook.Path 'dosyanın bulunduğu yola kaydeder
isim = s4.Range("C4").Value 'buradan dosya ismi atanabilir

' PDF OLARAK KAYDET

s4.Select ' a-t sütunları son dolu satıra kadar seçildi
s4.Range("A1:T" & sonsatirpdf).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & "/" & isim & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True

s4.Select
s4.Range("A1").Select

' XLSX OLARAK KAYDET

s2.Copy
ActiveWorkbook.SaveAs yol & "/" & isim & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True

'Pdf butonuna tıkladıktan sonra otomatik gelen data sayfası çıktısı alınır.

s2.PrintOut

' BİTTİ

Application.ScreenUpdating = True

End Sub

 

[PLİNT]

Merhaba
Aşağıdaki gibi olabilir

Dim s1  As Worksheet, _
s2  As Worksheet, _
s3  As Worksheet, _
s4  As Worksheet

Set s1 = ThisWorkbook.Sheets("yerli")
Set s2 = ThisWorkbook.Sheets("gelen data")
Set s3 = ThisWorkbook.Sheets("altformul")
Set s4 = ThisWorkbook.Sheets("pdf")

yol = ThisWorkbook.Path 'dosyanın bulunduğu yola kaydeder
isim = s4.Range("C4").Value 'buradan dosya ismi atanabilir
sonsatirpdf = s4.[A:T].Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
' PDF OLARAK KAYDET
10:
If Dir(yol & "\" & isim & v & ".pdf", vbDirectory) = "" Then
s4.Activate ' a-t sütunları son dolu satıra kadar seçildi
s4.Range("A1:T" & sonsatirpdf).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & "\" & isim & v & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True
Else
m = m + 1
v = "-" & m
GoTo 10
End If
s4.Select
s4.Range("A1").Select

' XLSX OLARAK KAYDET
20:
If Dir(yol & "\" & isim & v2 & ".xlsx", vbDirectory) = "" Then
s2.Copy
ActiveWorkbook.SaveAs yol & "\" & isim & v2 & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Else
s = s + 1
v2 = "-" & s
GoTo 20
End If
'Pdf butonuna tıkladıktan sonra otomatik gelen data sayfası çıktısı alınır.

s2.PrintOut

' BİTTİ

Application.ScreenUpdating = True