arkadaşlar makro konusunda en acemi benim diyebilirim. İlk defa kodları kullanmaya çalışıyorum. Bir internet sitesinde aldığım kod benim tam aradığım kod oldu. Yalnız biraz değişiklik yapmam gerekiyor.
Kodda görüldüğü gibi bir veri var. Veriyi c sütununda süzüyoruz. Daha sonra süzülen değerin aynısını doğra adı olarak farklı bir excel dosyasyı olarak kayd ediyoruz.
Buraya kadar sıkıntı yok. Benim istediğim verileri 1. satırdan itibaren süzmeye başlaması ve A sütunundaki verileri süzmesidir. Yapılacak iki değişiklik var. C sütunu yerine A sutunu, 2. satır yerine 1. satırdan süzmeye başlaması.
/////////////////////////////////////////////////////////////////////////////
DefInt I, S: DefObj A, D
Sub Filtrele_Farklı_Kaydet()
Application.ScreenUpdating = False
Sheets("Sayfa1").Select
With ActiveSheet
son1 = .Range("A65536").End(3).Row
For i = 2 To son1
If WorksheetFunction.CountIf(.Range("C2:C" & i), .Cells(i, "c")) = 1 Then
.Range("$A$2:$g$" & son1).AutoFilter Field:=3, Criteria1:=.Cells(i, 3)
Set dosya = CreateObject("Excel.Application")
Set ac = dosya.Workbooks.Add
dosya.Visible = False
.Cells.SpecialCells(12).Copy
ac.Sheets(1).Range("a1").PasteSpecial xlPasteValues
ac.SaveAs FileFormat:=51, Filename:=ThisWorkbook.Path & "\" & .Cells(i, 3) & ".xlsx"
dosya.Quit
Sheets("Sayfa1").Select
ActiveSheet.AutoFilterMode = False
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
i = Empty: son = Empty: son1 = Empty: Set ac = Nothing: Set dosya = Nothing
End Sub
//////////////////////////
Kodda görüldüğü gibi bir veri var. Veriyi c sütununda süzüyoruz. Daha sonra süzülen değerin aynısını doğra adı olarak farklı bir excel dosyasyı olarak kayd ediyoruz.
Buraya kadar sıkıntı yok. Benim istediğim verileri 1. satırdan itibaren süzmeye başlaması ve A sütunundaki verileri süzmesidir. Yapılacak iki değişiklik var. C sütunu yerine A sutunu, 2. satır yerine 1. satırdan süzmeye başlaması.
/////////////////////////////////////////////////////////////////////////////
DefInt I, S: DefObj A, D
Sub Filtrele_Farklı_Kaydet()
Application.ScreenUpdating = False
Sheets("Sayfa1").Select
With ActiveSheet
son1 = .Range("A65536").End(3).Row
For i = 2 To son1
If WorksheetFunction.CountIf(.Range("C2:C" & i), .Cells(i, "c")) = 1 Then
.Range("$A$2:$g$" & son1).AutoFilter Field:=3, Criteria1:=.Cells(i, 3)
Set dosya = CreateObject("Excel.Application")
Set ac = dosya.Workbooks.Add
dosya.Visible = False
.Cells.SpecialCells(12).Copy
ac.Sheets(1).Range("a1").PasteSpecial xlPasteValues
ac.SaveAs FileFormat:=51, Filename:=ThisWorkbook.Path & "\" & .Cells(i, 3) & ".xlsx"
dosya.Quit
Sheets("Sayfa1").Select
ActiveSheet.AutoFilterMode = False
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
i = Empty: son = Empty: son1 = Empty: Set ac = Nothing: Set dosya = Nothing
End Sub
//////////////////////////