iyi günler ,
Benim çalıştığım dosyada aşağıdaki gibi bir kod var ve bu kod sorunsuz çalışıyor.Bu kodu çalıştırdığım zaman bir pencere açılıyor ve bilgisayarımdaki herhangi bir excel dosyasını seçebiliyorum ve bu seçtiğim dosyadaki bilgiler çalıştığım excel dosyasına geliyor.
Benim sizden yardım etmenizi istediğim konu ise seçtiğim excel dosyasının içinden istediğim sheet ini kopyalamak,
örneğin herhangi.xls dosyasını seçtim bu dosyanın içindende sheet3 veya başka bir sheet i seçebilmem gerekiyor.
bunun için bu kodda nasıl bir ekleme yapmam gerekiyor ?
Sub VERİLERİ_AKTAR()
Dim Dosya_Yolu As String, Asıl_Dosya As Workbook, Kaynak_Dosya As Workbook
Application.ScreenUpdating = False
Set Asıl_Dosya = ThisWorkbook
Dosya_Yolu = DosyaAdiGetir()
Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu, False, False)
Kaynak_Dosya.ActiveSheet.Cells.Copy
Asıl_Dosya.Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Kaynak_Dosya.Close True
Set Kaynak_Dosya = Nothing
Set Asıl_Dosya = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Function DosyaAdiGetir()
On Error Resume Next
Dim i As Integer
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
i = Application.WorksheetFunction.Find("\", StrReverse(.SelectedItems(1)))
If i = 0 Then Exit Function
DosyaAdiGetir = Left(.SelectedItems(1), Len(.SelectedItems(1)) - i + 1) & Right(.SelectedItems(1), i - 1)
End With
End Function
Benim çalıştığım dosyada aşağıdaki gibi bir kod var ve bu kod sorunsuz çalışıyor.Bu kodu çalıştırdığım zaman bir pencere açılıyor ve bilgisayarımdaki herhangi bir excel dosyasını seçebiliyorum ve bu seçtiğim dosyadaki bilgiler çalıştığım excel dosyasına geliyor.
Benim sizden yardım etmenizi istediğim konu ise seçtiğim excel dosyasının içinden istediğim sheet ini kopyalamak,
örneğin herhangi.xls dosyasını seçtim bu dosyanın içindende sheet3 veya başka bir sheet i seçebilmem gerekiyor.
bunun için bu kodda nasıl bir ekleme yapmam gerekiyor ?
Sub VERİLERİ_AKTAR()
Dim Dosya_Yolu As String, Asıl_Dosya As Workbook, Kaynak_Dosya As Workbook
Application.ScreenUpdating = False
Set Asıl_Dosya = ThisWorkbook
Dosya_Yolu = DosyaAdiGetir()
Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu, False, False)
Kaynak_Dosya.ActiveSheet.Cells.Copy
Asıl_Dosya.Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Kaynak_Dosya.Close True
Set Kaynak_Dosya = Nothing
Set Asıl_Dosya = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Function DosyaAdiGetir()
On Error Resume Next
Dim i As Integer
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Show
i = Application.WorksheetFunction.Find("\", StrReverse(.SelectedItems(1)))
If i = 0 Then Exit Function
DosyaAdiGetir = Left(.SelectedItems(1), Len(.SelectedItems(1)) - i + 1) & Right(.SelectedItems(1), i - 1)
End With
End Function
Son düzenleme: