Döngü Yaratmak

Katılım
18 Aralık 2007
Mesajlar
15
Excel Vers. ve Dili
2003 ingilizce
Merhaba arkadaşlar, bi macrom var fakat döngü kuramadığım için tam anlamıyla bir macro sayılmaz :) İstediğim döngü şu şekilde; bir excel dosyam var ve burda yaklasık 800 kişinin bilgileri var(sicil,ad,calıstıgı şube,ünvan,maaş).yaptıgım macro filterda secili olan bilgileri sheet2ye kopyalayıp, sheet2 nin kopyasını alıp yeni bir dosya olustuyor ve dosya adını ilk kişinin yer aldıgı hücredeki calıstıgı sube hücresinden alarak dosyayı ilgili yere kaydediyor. ben her seferinde macro bitince ana dosyama geri dönüp bir sonraki şubeyi seçiyorum, yaklasık 250 şube var. 250 defa filtreden seçim yapmam gerekiyor yani :) macroya nasıl bir kod eklersem kendi her seferinde bir sonraki şubeyi seçsin ve dosyasını oluştursun. yani bir tuşla 250 dosya hazır olsun :) ben şu anda 250 defa bir sonraki şubeyi seçip macroyu çalıştırıyorum :( yardımlarınızı rica ediyorum ve cok tesekkür ediyorum.

örnek olarak bir dosya ekledim,birkaç satır var, normalde 800 satırlık bir dosya ile çalışıyorum.

macrom:
Sub SetFilteredRange()
Dim fname
Dim fpath
Dim fprefix As String
Dim FilterRange As Range

Set FilterRange = ActiveSheet.UsedRange.Offset(1, 0) _
.SpecialCells(xlCellTypeVisible)

FilterRange.Copy Destination:=Sheets("Sheet2").Range("c3")
Sheets("Sheet2").Select
Sheets("Sheet2").Copy
Columns("D:F").Select
Columns("D:F").EntireColumn.AutoFit
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="BURAK"
fprefix = Sheets("sheet2").Cells(3, 6).Value
fpath = "\\şubeler\giden dosyalar\"
fname = fprefix & ".xls"
ActiveWorkbook.SaveAs fpath & fname, FileFormat:=xlNormal, _
Password:="123654", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWorkbook.Close savechanges:=True
Windows("Kopyala yapıştır makrosu.xls").Activate
Sheets("Sheet2").Range("C3:K14").Select
Selection.ClearContents
Sheets("Sheet1").Select
MsgBox fprefix & " DOSYASI HAZIRLANMIŞTIR! "
End Sub
 
Üst