- Katılım
- 2 Mayıs 2013
- Mesajlar
- 50
- Excel Vers. ve Dili
- 2010
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
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