DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Private Sub CommandButton1_Click()
Z = TimeValue(Now)
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "Close_Excel.xlsx"
GetObject (yol & dosya)
Set dic = CreateObject("scripting.dictionary")
Set s1 = Workbooks(dosya).Sheets("Sheet1")
a = s1.Range("A2:AG" & s1.Cells(Rows.Count, 1).End(3).Row).Value
sutun = 3
For i = 1 To UBound(a)
krt = CStr(a(i, 1))
dic(krt) = i
Next i
Set s2 = Workbooks(ThisWorkbook.Name).Sheets("sheet1")
aa = s2.Range("A2:A" & s2.Cells(Rows.Count, 1).End(3).Row).Value
ReDim b(1 To UBound(aa), 1 To sutun)
For i = 1 To UBound(aa)
krt = CStr(aa(i, 1))
If dic.exists(krt) Then
For j = 1 To sutun
b(i, j) = a(dic(krt), j + 3)
Next j
End If
Next i
s2.[D2].Resize(UBound(aa), sutun) = b
Workbooks(dosya).Close
Application.ScreenUpdating = True
MsgBox CDate(TimeValue(Now) - Z)
End Sub
sutun = UBound(a, 2) - 1
b(i, j) = a(dic(krt), j)
s2.[B2].Resize(UBound(aa), sutun) = b
Option Explicit
Sub Veri_Aktar()
Dim Yol As String, Son As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Yol = ThisWorkbook.Path & Application.PathSeparator
Son = Cells(Rows.Count, 1).End(3).Row
Range("B2:C" & Rows.Count).ClearContents
With Range("B2:C" & Son)
.Formula = "=INDEX('" & Yol & "[Close_Excel.xlsx]Sheet1'!$A:$AD,MATCH($A2," & "'" & Yol & _
"[Close_Excel.xlsx]Sheet1'!$A:$A,0),MATCH(B$1,'" & Yol & "[Close_Excel.xlsx]Sheet1'!$1:$1,0))"
.Value = .Value
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Veri aktarım işlemi tamamlanmıştır.", vbInformation
End Sub
With Range("B2:C" & Son)
Range("B2:C" & Rows.Count).ClearContents