vba kodunda herbır sayfayı dosyadıyla kaydetmesini istiyorum

[ismailaslan07]

Merhaba, Aşagıdaki kod benim işimi görüyor fakat herbir sayfayı dosya ismiyle kaydetsin istiyorum.örnegin dosya adları BB3M_10_001_DİREKSİYON MİLİ HAZIRLAMA_OK ve BB3M_10_002_30 NOLU ÖN SOL HAVA BAĞLANTISI VE BRAKETİ HAZIRLAMA_OK olsun .
yeni bir dosyada sayfa isimleri BB3M_10_001 ve BB3M_10_002_30 olarak yazsın.
Teşkler,

Sub CombineFiles()

'Declare Variables
Dim WorkbookDestination As Workbook
Dim WorkbookSource As Workbook
Dim WorksheetSource As Worksheet
Dim FolderLocation As String
Dim strFilename As String
Dim i As Long

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

'This line will need to be modified depending on location of source folder
FolderLocation = "D:\BACKUP\BELGE\MASAÜSTÜ\EXCEL KATALOG\18m Konya\"

'Set the current directory to the the folder path.
ChDrive FolderLocation
ChDir FolderLocation

'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)

'Create a new workbook
Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(FolderLocation & "\*.xls", vbNormal)

If IsArray(SelectedFiles) Then

For i = LBound(SelectedFiles) To UBound(SelectedFiles)
Set WorkbookSource = Workbooks.Open(SelectedFiles(i))
Set WorksheetSource = WorkbookSource.Worksheets(1)
WorksheetSource.Copy After:=WorkbookDestination.Worksheets(WorkbookDestination.Worksheets.Count)
WorkbookSource.Close False
Next i

End If

WorkbookDestination.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

 

[halit3]

Sitede arama yaparsanız benzer bir sürü örnek bulabilirsiniz.

kod:

Sub Sayfaları_Çalışma_Kitabı_Yap_İçindeki_Makroları_Sil()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya = ThisWorkbook.FullName
dosya_adi = fL.GetBaseName(dosya)
uzanti = "." & fL.GetExtensionName(dosya)

If uzanti = ".xls" Then
If Val(Application.Version) >= 12 Then
FileFormatNum = 56
Else
FileFormatNum = -4143
End If

ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
ElseIf uzanti = ".txt" Then
FileFormatNum = -4143
ElseIf uzanti = ".csv" Then
FileFormatNum = 6
Else
FileFormatNum = 56
End If


If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"


On Error Resume Next
Dim sayfa As Worksheet
For Each sayfa In Worksheets


If CreateObject("Scripting.FileSystemObject").FileExists(Kaynak & sayfa.Name & uzanti) = True Then
MsgBox sayfa.Name & " Bu isimde bir dosya var"
'Exit Sub
Else
sayfa.Copy

For Each Component In ActiveWorkbook.VBProject.VBComponents
If Component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove Component
Else
Set modul = Component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next

ActiveSheet.DrawingObjects.Delete

ActiveWorkbook.SaveAs Kaynak & sayfa.Name & uzanti, FileFormat:=FileFormatNum
ActiveWorkbook.Close SaveChanges:=False
End If
Next sayfa

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub