seçili alana göre yazdırma ya da farklı kaydetme

[tukayf]

ekli dosyadaki sarı ile seçili alanların hepsini A sütununda bulunan isimlere göre farklı farklı dosya olarak kaydetmek istiyorum... kaydetme yeri olarak kendi bulunduğu klasörün içerisi olabilir. yardımlarınız için şimdiden teşekkürler

 

[Orion1]

Dosyanız ektedir.

Sub dosya_olustur59()
Dim dosya As String
Dim NewWb As Workbook
If Dir(ThisWorkbook.Path & "\HAVALIMANI.xlsx") <> "" Then
    MsgBox "HAVALİMANI Dosyası var!Havalimanı dosyası oluşturulmadı!!", vbCritical, "UYARI"
    GoTo park
End If
Set NewWb = Workbooks.Add
NewWb.SaveAs Filename:=ThisWorkbook.Path & "\HAVALIMANI.xlsx"
ThisWorkbook.Sheets("DOĞAN1").Range("A3:F19").Copy ActiveWorkbook.Sheets(1).Range("A1")
ActiveWorkbook.Close True
MsgBox "HAVALİMANI Dosyası başarı ile oluşturuldu.", vbOKOnly + vbInformation, Application.UserName
park:
If Dir(ThisWorkbook.Path & "\PARK.xlsx") <> "" Then
    MsgBox "PARK Dosyası var!Park dosyası oluşturulmadı!!", vbCritical, "UYARI"
    GoTo gar
End If
Set NewWb = Workbooks.Add
NewWb.SaveAs Filename:=ThisWorkbook.Path & "\PARK.xlsx"
ThisWorkbook.Sheets("DOĞAN1").Range("A21:F28").Copy ActiveWorkbook.Sheets(1).Range("A1")
ActiveWorkbook.Close True
MsgBox "PARK Dosyası başarı ile oluşturuldu.", vbOKOnly + vbInformation, Application.UserName
gar:
If Dir(ThisWorkbook.Path & "\GAR.xlsx") <> "" Then
    MsgBox "GAR Dosyası var!Gar dosyası oluşturulmadı!!", vbCritical, "UYARI"
    GoTo otogar
End If
Set NewWb = Workbooks.Add
NewWb.SaveAs Filename:=ThisWorkbook.Path & "\GAR.xlsx"
ThisWorkbook.Sheets("DOĞAN1").Range("A30:F35").Copy ActiveWorkbook.Sheets(1).Range("A1")
ActiveWorkbook.Close True
MsgBox "GAR Dosyası başarı ile oluşturuldu.", vbOKOnly + vbInformation, Application.UserName
otogar:
If Dir(ThisWorkbook.Path & "\OTOGAR.xlsx") <> "" Then
    MsgBox "OTOGAR Dosyası var!OTOGar dosyası oluşturulmadı!!", vbCritical, "UYARI"
    GoTo durak
End If
Set NewWb = Workbooks.Add
NewWb.SaveAs Filename:=ThisWorkbook.Path & "\OTOGAR.xlsx"
ThisWorkbook.Sheets("DOĞAN1").Range("A38:F44").Copy ActiveWorkbook.Sheets(1).Range("A1")
ActiveWorkbook.Close True
MsgBox "OTOGAR Dosyası başarı ile oluşturuldu.", vbOKOnly + vbInformation, Application.UserName
durak:
If Dir(ThisWorkbook.Path & "\DURAK.xlsx") <> "" Then
    MsgBox "DURAK Dosyası var!DURAK dosyası oluşturulmadı!!", vbCritical, "UYARI"
    GoTo son
End If
Set NewWb = Workbooks.Add
NewWb.SaveAs Filename:=ThisWorkbook.Path & "\DURAK.xlsx"
ThisWorkbook.Sheets("DOĞAN1").Range("A46:F51").Copy ActiveWorkbook.Sheets(1).Range("A1")
ActiveWorkbook.Close True
MsgBox "DURAK Dosyası başarı ile oluşturuldu.", vbOKOnly + vbInformation, Application.UserName
son:
MsgBox "İşlem bitti."
End Sub

 

[tukayf]

zihninize ve klavyenize sağlık hocam. cok güzel olmuş.

 

[Orion1]

zihninize ve klavyenize sağlık hocam. cok güzel olmuş.

Rica ederim.
İyi çalışmalar.