Mükerrersiz aktar

[mcetinkaya65]

Sayfa1 A stununda a2 den sonraki tc leri tekrarsız olarak sayfa2 nin a2 hücresinden başlayarak b stunundaki isimle birlikte aktarması mümkün mü

Saygılarımla...

 

[Saban Sertkaya]

Merhabalar,
Verinizi sayfa 2'ye kopyalayın. A ve B sütunun tutun. "Veri" sekmesi altındaki "Yinelenenleri Kaldır" butonuna tıklayın. TC'nin olduğu sütunu seçili bırakın. "Tamam" tuşuna tıklayın.
Böylece TC'ye göre mükerrersiz işleminizi halletmiş olursunuz.

 

[Ziynettin]

......

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet, a(), dc As Object
Dim i As Long, krt As String, say As Long, j As Byte
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set dc = CreateObject("scripting.dictionary")

a = s1.Range("A1:H" & s1.Cells(Rows.Count, 1).End(xlUp).Row).Value

For i = 2 To UBound(a)
    krt = CStr(a(i, 1))
    If Not dc.exists(krt) Then
        dc(krt) = dc.Count + 1
        say = dc.Count
        For j = 1 To UBound(a, 2)
            a(say, j) = a(i, j)
        Next j
    Else
        say = dc(krt)
        For j = 3 To UBound(a, 2)
            If a(i, j) <> "" Then
                a(say, j) = a(i, j)
            End If
        Next j
    End If
Next i

If dc.Count > 0 Then
    Application.ScreenUpdating = False
    s2.Range("A2:H" & Rows.Count).Borders.LineStyle = xlNone
        With s2.[A2].Resize(dc.Count, UBound(a, 2))
            .Value = a
            .Borders.Weight = xlHairline
            .BorderAround , xlMedium
        End With
    Application.ScreenUpdating = True
    MsgBox "Verileriniz aktarıldı.", vbInformation
Else
    MsgBox "İşlem bulunamadı.", vbCritical
End If
End Sub

 

[çıtır]

Alternatif olarak

Sub Sayfa2kayıt()
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim son As Long
Dim sd As Object: Dim i As Long
Dim liste(): Dim Dizi()
   Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
   Zaman = Timer
    son = s1.Cells(1048541, "A").End(3).Row
    sonkolon = s1.Cells(1, 256).End(1).Column
    liste = s1.Range(s1.Cells(1, 1), s1.Cells(son, sonkolon)).Value
    Set sd = CreateObject("Scripting.Dictionary")
     For ii = 3 To sonkolon
    For i = 1 To UBound(liste, 1)
    If liste(i, 1) <> "" Then
    aranan = liste(i, 1)
    If Not sd.Exists(aranan) Then
            say = say + 1
            sd.Add aranan, say
            ReDim Preserve Dizi(1 To son, 1 To sonkolon)
            Dizi(say, 1) = liste(i, 1): Dizi(say, 2) = liste(i, 2)
           End If
        If Dizi(sd.Item(aranan), ii) + liste(i, ii) > 0 Then
        Dizi(sd.Item(aranan), ii) = Dizi(sd.Item(aranan), ii) + liste(i, ii)
         End If
        End If

    Next i
    Next ii
If sd.Count > 0 Then
s2.Range("A1").CurrentRegion.ClearContents
s2.Range("A1").Resize(sd.Count, sonkolon) = Dizi
     son1 = s2.Cells(1048541, "A").End(3).Row
  With s2.Range(s2.Cells(1, 1), s2.Cells(son1, sonkolon))
.Borders.LineStyle = 1
.BorderAround LineStyle:=xlContinuous, ColorIndex:=1, Weight:=xlThin
End With
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
MsgBox "Değer yok." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    End If
    i = Empty:  ii = Empty: son = Empty: son1 = Empty: Erase liste: Erase Dizi
  Set s1 = Nothing: Set s2 = Nothing: Set sd = Nothing
   
    End Sub

 

[mcetinkaya65]

İlginize bilginize teşekkürler.
Hepinizden Allah razı olsun.

 

[Saban Sertkaya]

Amin, cümlemizden.