DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub Aktar()
Dim K1 As Workbook, S1 As Worksheet
Dim K2 As Workbook, S2 As Worksheet
Dim Yol As String, Dosya_Adi As String
Dim XL_App As Object, Son As Long, Satir As Long
Application.ScreenUpdating = False
Set K1 = ThisWorkbook
Set S1 = K1.Sheets("ANALİZ")
Yol = "\\192.168.16.11\hosabproje\PROJE\"
Dosya_Adi = Yol & "Arsiv.xlsm"
If Dir(Dosya_Adi) <> "" Then
Set XL_App = CreateObject("Excel.Application")
XL_App.Visible = False
Set K2 = XL_App.Workbooks.Open(Dosya_Adi)
Set S2 = K2.Sheets("ANALİZ")
Son = Evaluate("LOOKUP(2,1/('" & S1.Name & "'!A1:A10000<>""""),ROW('" & S1.Name & "'!A1:A10000))")
Satir = S2.ListObjects("Tablo2").Range.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
S2.Range("A" & Satir & ":T" & Satir + Son - 2).Value = S1.Range("A2:T" & Son).Value
K2.Close (True)
Set S2 = Nothing
Set K2 = Nothing
Set XL_App = Nothing
Application.ScreenUpdating = True
MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
Else
Application.ScreenUpdating = True
MsgBox "Aktarım yapılacak dosya bulunamadı!", vbCritical
End If
Set S1 = Nothing
Set K1 = Nothing
End Sub