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
ö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