Gözat penceresi ile sayfa kopyalama.

Katılım
9 Eylül 2010
Mesajlar
867
Excel Vers. ve Dili
2016&2019&2021 TR
Altın Üyelik Bitiş Tarihi
29-09-2023
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.
 

Ekli dosyalar

Katılım
9 Eylül 2010
Mesajlar
867
Excel Vers. ve Dili
2016&2019&2021 TR
Altın Üyelik Bitiş Tarihi
29-09-2023
Değerli hocalarim mümkünse çözüm bekliyorum.
 
Katılım
9 Eylül 2010
Mesajlar
867
Excel Vers. ve Dili
2016&2019&2021 TR
Altın Üyelik Bitiş Tarihi
29-09-2023
PQ ile yavaşta olsa verileri çekiyorum ancak yeni bir sayfaya alıyor verileri aynı sayfaya almak için ne yapmamız lazım.
 
Katılım
9 Eylül 2010
Mesajlar
867
Excel Vers. ve Dili
2016&2019&2021 TR
Altın Üyelik Bitiş Tarihi
29-09-2023
Dim Dosya As String
Kod:
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.
 
Son düzenleme:

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Aşağıdaki kodu deneyin.
Kod:
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
 
Katılım
9 Eylül 2010
Mesajlar
867
Excel Vers. ve Dili
2016&2019&2021 TR
Altın Üyelik Bitiş Tarihi
29-09-2023
Hocam kodda bir sorun var sanırım sadece A2yi kopyaladı bıraktı.
 

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Mümkün değil ama aşağıdaki alternatif kodu deneyebilirsiniz.
Aynı işlemi yapar.
Kod:
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
 
Üst