veri aktarma

[Ziynettin]

Ekli dosyada formül yok ona göre çalışma yapıldı. Gerçek dosyanıza uygun formül vs. bulunan dosyanızı ekleyin. Formüller nerede görelim.

 

[metin_0606]

Ekli dosyada formül yok ona göre çalışma yapıldı. Gerçek dosyanıza uygun formül vs. bulunan dosyanızı ekleyin. Formüller nerede görelim.

Ziynettin hocam sizden aldığım kod tabloda sarı dolgu ile işaretlediğim sütunlara ait mevcut veriler, verileri aktardıktan sonra siliyor kod ve tablo ektedir saygılar

 

[Ziynettin]

Bu şekilde deneyiniz.

Sub AKTAR_80()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("VERİ")
Set dc = CreateObject("scripting.dictionary")
tm = TimeValue(Now)
a = s2.Range("A2:H" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(a)
    dc(CStr(a(i, 1))) = i
Next i
Set tbl = s1.Range("B2:Z" & s1.Cells(Rows.Count, 3).End(xlUp).Row)
b = tbl.Value
ReDim w(1 To UBound(b), 1 To UBound(b, 2))
For i = 1 To UBound(b)
    For j = 1 To UBound(b, 2)
        w(i, j) = b(i, j)
    Next j
    If b(i, 23) = "Etkin" Then
        deg = CStr(b(i, 2))
        If dc.exists(deg) Then
            n = dc(deg)
            tbl.Cells(i, 1) = a(n, 2)
            tbl.Cells(i, 4) = a(n, 3)
            tbl.Cells(i, 8) = a(n, 4)
            tbl.Cells(i, 20) = a(n, 5)
            tbl.Cells(i, 25) = a(n, 6)
            tbl.Cells(i, 12) = a(n, 7)
        End If
    End If
Next i
MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - tm), vbInformation
End Sub

 

[metin_0606]

Bu şekilde deneyiniz.

Sub AKTAR_80()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("VERİ")
Set dc = CreateObject("scripting.dictionary")
tm = TimeValue(Now)
a = s2.Range("A2:H" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(a)
    dc(CStr(a(i, 1))) = i
Next i
Set tbl = s1.Range("B2:Z" & s1.Cells(Rows.Count, 3).End(xlUp).Row)
b = tbl.Value
ReDim w(1 To UBound(b), 1 To UBound(b, 2))
For i = 1 To UBound(b)
    For j = 1 To UBound(b, 2)
        w(i, j) = b(i, j)
    Next j
    If b(i, 23) = "Etkin" Then
        deg = CStr(b(i, 2))
        If dc.exists(deg) Then
            n = dc(deg)
            tbl.Cells(i, 1) = a(n, 2)
            tbl.Cells(i, 4) = a(n, 3)
            tbl.Cells(i, 8) = a(n, 4)
            tbl.Cells(i, 20) = a(n, 5)
            tbl.Cells(i, 25) = a(n, 6)
            tbl.Cells(i, 12) = a(n, 7)
        End If
    End If
Next i
MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - tm), vbInformation
End Sub

Sorun aynen devam ediyor