Kapalı dosyayı açıp istediğiniz sayfaları kendi dosyanıza aktarmak

[Orion1]

Userfomda listbox multiline seçildi.A:Z aralığını kopyalar.
Eğer 2003 ve altı yüklü ise sdace 2003 ve altı excel dosyalarını yukarsı yüklü ise hepsini folder windowsta görüntüler.

Kod: [Seç]

Private Sub CommandButton1_Click()
Dim i As Integer, say As Integer
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
        say = say + 1
        If say <= ThisWorkbook.Worksheets.Count Then
            Workbooks(dosya).Sheets(ListBox1.List(i, 0)).Range("A1:Z" & sat).Copy ThisWorkbook.Sheets(say).Range("A1")
        End If
    End If
Next i
Unload Me
End Subsayfadaki butondaki kod:

Kod: [Seç]

Public dsy, dosya As String, sat As Long
Sub dosya_ac_59()
Dim klasor As String, sh As Worksheet, ds As Object, f As String
Dim uzanti As String
Set ds = CreateObject("Scripting.FileSystemObject")
f = ds.GetExtensionName(ThisWorkbook.FullName)
If Len(f) = 3 Then
    uzanti = "Excel dosyaları,*.xls"
    sat = 65536
    ElseIf Len(f) = 4 Then
    uzanti = "Excel dosyaları,*.xls;*.xlsx;*.xlsm"
    sat = 1000000
End If
Sheets(1).Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each sh In Worksheets
    sh.Range("A1:Z" & sat).Clear
Next
klasor = CreateObject("wscript.shell").SpecialFolders(10)
ChDir (klasor)
dsy = Application.GetOpenFilename(filefilter:=uzanti, Title:="DOSYA SEÇİNİZ.")
If dsy = "" Or dsy = False Then
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "dosya seçilmedi.İşlem iptal edildi", vbCritical, "UYARI"
Exit Sub
End If
If MsgBox(dsy & " Kaydetmek istiyormususnuz?", vbYesNo + vbQuestion) = vbNo Then
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Hayır seçeneği seçildi.Kayıt İptal edildi", vbCritical, "İPTAL"
Exit Sub
End If
dosya = Dir(dsy)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Workbooks.Open(dsy).ReadOnly Then Workbooks(dosya).Close
Application.DisplayAlerts = True
UserForm1.ListBox1.Clear
For Each sh In Workbooks(dosya).Worksheets
    UserForm1.ListBox1.AddItem sh.Name
Next
UserForm1.Show
Workbooks(dosya).Close False
ThisWorkbook.Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.Visible = True
MsgBox "Diğer dosyadan kayıt alındı." & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub
[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[Bülent Öztürk]

Elinize sağlık Evren Bey.

[Orion1]

Elinize sağlık Evren Bey.

Teşekkür ederim.Bülent bey

[1Al2Ver]

Sayın Evren Gizlen, merhaba,

Paylaşım için teşekkürler...

[Puletin]

Evren hocam eline sağlık...

[Orion1]

Rica ederim.
İyi çalışmalar.