Makro ile Farklı Excell Açıp, İçinden Data Kopyalamak

[bjkliislam]

Merhabalar;


\\ablkfs\BLK_ORTAK\KALITE_KONTROL\MELAMİN_PRESLER_TEST_SONUCLARI\YONGA LEVHA LABORATUVAR\MACRO FULL TEST İŞLEME\LAK KOLAY İŞLEME\FULL TEST ŞABLON.xls

Ekteki konumdaki şablon excell i makro ile açıp, a2:f7 aralığını kopyalayıp active workbooka yapıştırmak istiyorum. sonra da şablon excell ini kapatmak istiyorum.

Hangi kodları kullanmam gerekmektedir?

Teşekkür ederim.

iyi çalışmalar.
saygılarımla.

 

[bjkliislam]

Merhabalar;

Konuyla ilgili yardımcı olabilecek var mı?

 

[bmutlu966]

Sanırım işinizi görür.

 

[bjkliislam]

Sanırım işinizi görür.

Altın üye olmadığım için dosyayı indiremiyorum.

 

[bmutlu966]

Aşağıdaki kodları bir modüle kopyalayıp makroya bir tuş atayın.
Makroyu çalıştıracağınız sayfanın ismini de Veri al yapmalısınız.

Sub sablondan_al()

Application.ScreenUpdating = False
Application.DisplayAlerts = False


   
    On Error Resume Next
    Dim XDosya As Workbook
    Dim xAlan As Range
    Dim Time1 As Date, Time2 As Date
    Dim timeElapsed As String, myFile As String
    Dim Dosya As Variant
   
    Sheets("Veri al").Select
Range("A2:F7").Select
    Selection.ClearContents
Range("A1").Select


   
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyasi,*.xls; *.xlsb; *.xlsx; *.xlsm", MultiSelect:=True)
    If Dosya(1) = Empty Then
   MsgBox "Lütfen önce Dosya seçiniz.", vbExclamation
        Exit Sub
    End If

     
       Set xAlan = Workbooks.Open(Dosya(1)).ActiveSheet.Range("A2:F7") 'veri alinacak dosya bilgileri
    ThisWorkbook.Worksheets("Veri al").Range("A2:F7") = xAlan.Value 'veri aktarilacak alan bilgileri
    xAlan.Parent.Parent.Close

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

 

[bjkliislam]

Aşağıdaki kodları bir modüle kopyalayıp makroya bir tuş atayın.
Makroyu çalıştıracağınız sayfanın ismini de Veri al yapmalısınız.

Sub sablondan_al()

Application.ScreenUpdating = False
Application.DisplayAlerts = False


  
    On Error Resume Next
    Dim XDosya As Workbook
    Dim xAlan As Range
    Dim Time1 As Date, Time2 As Date
    Dim timeElapsed As String, myFile As String
    Dim Dosya As Variant
  
    Sheets("Veri al").Select
Range("A2:F7").Select
    Selection.ClearContents
Range("A1").Select


  
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyasi,*.xls; *.xlsb; *.xlsx; *.xlsm", MultiSelect:=True)
    If Dosya(1) = Empty Then
   MsgBox "Lütfen önce Dosya seçiniz.", vbExclamation
        Exit Sub
    End If

    
       Set xAlan = Workbooks.Open(Dosya(1)).ActiveSheet.Range("A2:F7") 'veri alinacak dosya bilgileri
    ThisWorkbook.Worksheets("Veri al").Range("A2:F7") = xAlan.Value 'veri aktarilacak alan bilgileri
    xAlan.Parent.Parent.Close

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Yardımlarınız için teşekkür ederim. Gerekli kodları aldım.