Yeni bir dosya oluşturmak

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar herkese iyi akşamlar;
Ekli dosyamda Personel Listesi diye bir dosyam var. Bu dosyadaki verilere göre ikinci dosyam olan "OCAK AYI KESİNTİSİ" şeklinde D\Belgelerim\Aylık\ klasörüne dosya oluşturmasını istiyorum. örnek dosya ekte saygılarımla.
http://s7.dosya.tc/server2/1mduo1/Desktop.rar.html
Herkese iyi akşamlar kolay gelsin.

 

[PLİNT]

Merhaba
Aşağıdaki kodları "LİSTE" sayfasındaki butona ekleyip deneyin.

[SIZE="2"]Private Sub CommandButton1_Click()
Dim s1 As Object, s3 As Object, s4 As Object
Dim s2 As Worksheet
Dim s3x As Long, s4x As Long, a As Long
Dim yol As String, buay As String
Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")
If ds.FolderExists("D:\Belgelerim") = False Then ds.CreateFolder "D:\Belgelerim"
If ds.FolderExists("D:\Belgelerim\Aylık") = False Then ds.CreateFolder "D:\Belgelerim\Aylık"
yol = "D:\Belgelerim\Aylık\"
Application.ScreenUpdating = False
ThisWorkbook.Sheets("LİSTE").Copy
Set S1 = ActiveWorkbook
Set s4 = ActiveWorkbook.ActiveSheet
s4x = s4.Cells(Rows.Count, "C").End(3).Row
For a = 1 To s4x
s4.Cells(a, "C") = s4.Cells(a, "C") & " " & s4.Cells(a, "D")
Next
s4.Range("D:D,G:X").Delete Shift:=xlToLeft
s4.Columns("E:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
s4.Columns("G:G").Cut s4.Columns("E:E")
s4.Cells(1, "E") = "MİKTAR"
s4.DrawingObjects.Delete
S1.Sheets.Add After:=S1.Sheets(S1.Sheets.Count)
Set s3 = S1.Sheets(S1.Sheets.Count)
Set S2 = Windows("PERSONEL LİSTESİ.xlsm").ActiveSheet
s4.Cells.Copy: s3.Paste
s3.Range("E2:E" & s4x).SpecialCells(xlCellTypeConstants, 1).Cells.EntireRow.Delete Shift:=xlUp
s4.Range("E2:E" & s4x).SpecialCells(xlCellTypeConstants, 2).Cells.EntireRow.Delete Shift:=xlUp
s4.Name = "KESİLEN": s3.Name = "KESİLMEYEN"
s4x = s4.Cells(Rows.Count, "C").End(3).Row
s4.Cells(2, 1) = "1"
s4.Cells(2, 1).AutoFill Destination:=s4.Range("A2:A" & s4x), Type:=xlFillSeries
  s3x = s3.Cells(Rows.Count, "C").End(3).Row
s3.Cells(2, 1) = "1"
s3.Cells(2, 1).AutoFill Destination:=s3.Range("A2:A" & s3x), Type:=xlFillSeries
buay = MonthName(DatePart("m", Date), False) & " AYI KESİNTİSİ"
Application.DisplayAlerts = False
S1.SaveAs Filename:=yol & buay & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.DisplayAlerts = True
S1.Close
Application.ScreenUpdating = True
End Sub[/SIZE]

 

[Hacı Bayram ÖZKAN]

Sayın abim teşekkürler şimdilik vaktim yok akşam deneyeceğim, eline sağlık dua ile kal. Zahmet verdim. Allah razı olsun