Gözat penceresi ile sayfa kopyalama.

[tukayf]

Gözat penceresinden adında GunlukGorevListesi geçen xls dosyasını seçmek ve seçtiğim kitap içerisindeki GorevListesi sayfasının tümünü ya da A2:Q aralığını kopyalayarak GunlukGorevListesi dosyası GorevListesi sayfasına almak istiyorum.
Epey uğraştım yapamadım yardımlarınızı rica ediyorum.

 

[tukayf]

Değerli hocalarim mümkünse çözüm bekliyorum.

 

[tukayf]

PQ ile yavaşta olsa verileri çekiyorum ancak yeni bir sayfaya alıyor verileri aynı sayfaya almak için ne yapmamız lazım.

 

[tukayf]

Dim Dosya As String

Sub Gozat()
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)
End Sub
Sub VeriAl()
    Dim XDosya As Workbook
    Dim xAlan As Range
    If Dosya = Empty Then
        MsgBox "Lütfen önce Dosya seçiniz.", vbExclamation
        Exit Sub
    End If
    Set xAlan = Workbooks.Open(Dosya).Worksheets("GorevListesi").Range("A2:Q")
    ThisWorkbook.Worksheets("GorevListesi").Range("A2:Q") = xAlan.Value
    xAlan.Parent.Parent.Close
End Sub

Bu kodlar Muzaffer Ali Bey'in dosyaya uyarladığımda tepki vermiyor acaba nerede hata yapıyorum.

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu deneyin.

Sub VeriAl()
    Dim XDosya As Workbook
    Dim xSayfa As Worksheet
    Dim xAlan As Range
    Dim Dosya As String
    
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)
    If Dosya = Empty Then
        MsgBox "Lütfen önce Dosya seçiniz.", vbExclamation
        Exit Sub
    End If
    Set xSayfa = Workbooks.Open(Dosya).Worksheets("GorevListesi")
    Set xAlan = xSayfa.Range("A2:Q" & xSayfa.Rows.Count)
    ThisWorkbook.Worksheets("GorevListesi").Range("A2") = xAlan.Value
    xAlan.Parent.Parent.Close
End Sub

 

[tukayf]

Hocam kodda bir sorun var sanırım sadece A2yi kopyaladı bıraktı.

 

[Muzaffer Ali]

Mümkün değil ama aşağıdaki alternatif kodu deneyebilirsiniz.
Aynı işlemi yapar.

Sub VeriAl()
    Dim XDosya As Workbook
    Dim xSayfa As Worksheet
    Dim Dosya As String
   
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)
    If Dosya = Empty Then
        MsgBox "Lütfen önce Dosya seçiniz.", vbExclamation
        Exit Sub
    End If
    Set xSayfa = Workbooks.Open(Dosya).Worksheets("GorevListesi")
    xSayfa.Range("A2:Q" & xSayfa.Rows.Count).copy ThisWorkbook.Worksheets("GorevListesi").Range("A2")
    xSayfa.Parent.Close
End Sub