2 Excel Dosyası Tek DosyaOlabilirmi

[Robinson_Crusoe]

Diyelimki arkadaşlar a.xls uzantılı bir dosyamız var a.xls dosyasının 1 nci sayfasını alıp b.xls dosyasının 2 nci sayfasına kopyalanmasını istiyoruz bunu yapmamızın bir yolu varmı çünkü a dosyasındaki a sayfadaki bilgileri birden fazla b dosyası gibi dosyalara kopyalamam lazım,

 

[numan şamil]

Merhaba
Değeri Halit03 hocanın kodları işini görür sanırım
b.xls dosyasında bir modül açıp kodları kopyalayıp yapıştırın ve bir düğmeye atayın

Sub sayfakopyalama()
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

a = Application.GetOpenFilename(filefilter:="Excel Workbooks,*.xls", Title:="Open a File", MultiSelect:=False)
If a = False Then
MsgBox "Kaynak klasörü seçmediniz"
Exit Sub
End If

Kaynak = Mid(a, 1, Len(a) - Len(Dir(a)) - 1)
deg = "'" & Kaynak & "\" & "[" & Dir(a) & "]" & "x" & "'!R"

Cells(1, 1).Value = "=" & deg & 1 & "C" & 1
Cells(1, 1).Replace What:="=", Replacement:=""

alan1 = Worksheets(ActiveSheet.Name).Cells(1, 1).Value
For k = 1 To Len(alan1)
If Mid(alan1, k, 1) = "]" Then
yer = (Len(alan1) - 6 - k)
sayfaadı = Mid(alan1, k + 1, yer)
End If
Next

Cells(1, 1).Value = sayfaadı

Dim Dosya
Dim wb As Workbook
Dosya = Dir(a)

If a = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If

Set wb = Workbooks.Open(a)
yeni_dosya_adı = ActiveWorkbook.Name
Windows(yeni_dosya_adı).Activate
Sheets(sayfaadı).Select
On Error Resume Next
Application.DisplayAlerts = False
Sheets(sayfaadı).Copy Before:=Workbooks(dosya_adı).Sheets(1)

Windows(yeni_dosya_adı).Activate
Application.DisplayAlerts = False
'ActiveWorkbook.Save
ActiveWindow.Close

Windows(dosya_adı).Activate
Sheets(Sayfa_Adı).Select
Cells(1, 1).Value = ""
ActiveWindow.WindowState = xlMaximized
MsgBox "işlem tamam"

   
End Sub